cabal-install 2.0.0.1 → 2.2.0.0

raw patch · 121 files changed

+8214/−4919 lines, 121 filesdep +cabal-installdep +resolvdep +windnsdep −bytestring-builderdep −ghc-primdep −old-timedep ~Cabaldep ~HTTPdep ~Win32

Dependencies added: cabal-install, resolv, windns

Dependencies removed: bytestring-builder, ghc-prim, old-time

Dependency ranges changed: Cabal, HTTP, Win32, array, async, base, base16-bytestring, binary, bytestring, cryptohash-sha256, directory, filepath, hackage-security, hashable, mtl, network, network-uri, pretty, pretty-show, process, random, stm, tar, tasty, time, unix, zlib

Files

Distribution/Client/BuildReports/Anonymous.hs +11/−10
Distribution/Client/BuildReports/Storage.hs +4/−5
Distribution/Client/Check.hs +34/−18
Distribution/Client/CmdBench.hs +17/−20
Distribution/Client/CmdBuild.hs +9/−12
Distribution/Client/CmdConfigure.hs +15/−8
Distribution/Client/CmdErrorMessages.hs +79/−27
Distribution/Client/CmdExec.hs +259/−0
Distribution/Client/CmdFreeze.hs +7/−10
Distribution/Client/CmdHaddock.hs +21/−16
Distribution/Client/CmdInstall.hs +369/−0
Distribution/Client/CmdRepl.hs +10/−12
Distribution/Client/CmdRun.hs +163/−56
Distribution/Client/CmdTest.hs +16/−19
Distribution/Client/CmdUpdate.hs +212/−0
Distribution/Client/Compat/Directory.hs +13/−0
Distribution/Client/Compat/FileLock.hsc +1/−4
Distribution/Client/Compat/FilePerms.hs +2/−3
Distribution/Client/Compat/Semaphore.hs +2/−2
Distribution/Client/Config.hs +86/−46
Distribution/Client/Configure.hs +12/−20
Distribution/Client/Dependency.hs +103/−37
Distribution/Client/DistDirLayout.hs +9/−5
Distribution/Client/Fetch.hs +17/−3
Distribution/Client/FetchUtils.hs +1/−1
Distribution/Client/GenBounds.hs +5/−7
Distribution/Client/Get.hs +3/−4
Distribution/Client/GlobalFlags.hs +13/−9
Distribution/Client/HttpUtils.hs +103/−66
Distribution/Client/IndexUtils.hs +86/−123
Distribution/Client/Init.hs +81/−41
Distribution/Client/Init/Types.hs +6/−4
Distribution/Client/Install.hs +22/−25
Distribution/Client/InstallPlan.hs +3/−4
Distribution/Client/List.hs +14/−14
Distribution/Client/Nix.hs +2/−7
Distribution/Client/Outdated.hs +17/−15
Distribution/Client/PackageHash.hs +45/−9
Distribution/Client/ParseUtils.hs +4/−4
Distribution/Client/ProjectBuilding.hs +85/−15
Distribution/Client/ProjectBuilding/Types.hs +1/−0
Distribution/Client/ProjectConfig.hs +49/−40
Distribution/Client/ProjectConfig/Legacy.hs +157/−97
Distribution/Client/ProjectConfig/Types.hs +21/−11
Distribution/Client/ProjectOrchestration.hs +210/−82
Distribution/Client/ProjectPlanOutput.hs +105/−30
Distribution/Client/ProjectPlanning.hs +368/−137
Distribution/Client/ProjectPlanning/Types.hs +50/−3
Distribution/Client/Reconfigure.hs +6/−8
Distribution/Client/Sandbox.hs +0/−4
Distribution/Client/Sandbox/Index.hs +6/−2
Distribution/Client/Sandbox/PackageEnvironment.hs +3/−3
Distribution/Client/Security/DNS.hs +62/−12
Distribution/Client/Setup.hs +136/−39
Distribution/Client/SetupWrapper.hs +32/−33
Distribution/Client/SolverInstallPlan.hs +3/−4
Distribution/Client/SourceRepoParse.hs +22/−0
Distribution/Client/SrcDist.hs +0/−5
Distribution/Client/Store.hs +7/−2
Distribution/Client/TargetSelector.hs +571/−386
Distribution/Client/Targets.hs +20/−76
Distribution/Client/Types.hs +226/−8
Distribution/Client/Update.hs +38/−16
Distribution/Client/Upload.hs +2/−2
Distribution/Client/Utils.hs +25/−2
Distribution/Client/Win32SelfUpgrade.hs +1/−1
Distribution/Client/World.hs +11/−9
Distribution/Solver/Compat/Prelude.hs +19/−0
Distribution/Solver/Modular.hs +122/−10
Distribution/Solver/Modular/Assignment.hs +10/−68
Distribution/Solver/Modular/Builder.hs +91/−66
Distribution/Solver/Modular/ConflictSet.hs +4/−4
Distribution/Solver/Modular/Cycles.hs +2/−3
Distribution/Solver/Modular/Dependency.hs +91/−237
Distribution/Solver/Modular/Explore.hs +19/−16
Distribution/Solver/Modular/Flag.hs +32/−16
Distribution/Solver/Modular/Index.hs +5/−7
Distribution/Solver/Modular/IndexConversion.hs +206/−95
Distribution/Solver/Modular/LabeledGraph.hs +1/−1
Distribution/Solver/Modular/Linking.hs +62/−61
Distribution/Solver/Modular/Log.hs +18/−37
Distribution/Solver/Modular/Message.hs +68/−70
Distribution/Solver/Modular/PSQ.hs +0/−8
Distribution/Solver/Modular/Package.hs +4/−6
Distribution/Solver/Modular/Preference.hs +28/−12
Distribution/Solver/Modular/Solver.hs +37/−30
Distribution/Solver/Modular/Tree.hs +17/−5
Distribution/Solver/Modular/Validate.hs +259/−36
Distribution/Solver/Modular/Var.hs +6/−18
Distribution/Solver/Modular/Version.hs +2/−2
Distribution/Solver/Modular/WeightedPSQ.hs +11/−0
Distribution/Solver/Types/ComponentDeps.hs +1/−1
Distribution/Solver/Types/ConstraintSource.hs +6/−0
Distribution/Solver/Types/PackageConstraint.hs +18/−2
Distribution/Solver/Types/PackageIndex.hs +1/−1
Distribution/Solver/Types/PackagePath.hs +4/−6
Distribution/Solver/Types/PkgConfigDb.hs +1/−1
Distribution/Solver/Types/Progress.hs +1/−1
Distribution/Solver/Types/SolverPackage.hs +2/−2
Distribution/Solver/Types/Variable.hs +2/−3
Main.hs +0/−1226
bootstrap.sh +48/−100
cabal-install.cabal +361/−634
changelog +76/−3
main/Main.hs +1229/−0
tests/IntegrationTests2.hs +59/−79
tests/IntegrationTests2/targets/lib-only/p.cabal +8/−0
tests/UnitTests.hs +3/−3
tests/UnitTests/Distribution/Client/ProjectConfig.hs +246/−71
tests/UnitTests/Distribution/Client/Store.hs +2/−2
tests/UnitTests/Distribution/Client/Tar.hs +2/−2
tests/UnitTests/Distribution/Client/Targets.hs +9/−8
tests/UnitTests/Distribution/Client/UserConfig.hs +5/−5
tests/UnitTests/Distribution/Solver/Modular/Builder.hs +20/−0
tests/UnitTests/Distribution/Solver/Modular/DSL.hs +79/−69
tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +84/−34
tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs +101/−7
tests/UnitTests/Distribution/Solver/Modular/PSQ.hs +0/−22
tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +171/−48
tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs +33/−0
tests/UnitTests/Distribution/Solver/Modular/Solver.hs +435/−88

Distribution/Client/BuildReports/Anonymous.hs view

@@ -26,6 +26,9 @@ --    showList,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (show)+ import qualified Distribution.Client.Types as BR          ( BuildOutcome, BuildFailure(..), BuildResult(..)          , DocsResult(..), TestsResult(..) )@@ -36,7 +39,8 @@ import Distribution.Package          ( PackageIdentifier(..), mkPackageName ) import Distribution.PackageDescription-         ( FlagName, mkFlagName, unFlagName, FlagAssignment )+         ( FlagName, mkFlagName, unFlagName+         , FlagAssignment, mkFlagAssignment, unFlagAssignment ) import Distribution.Version          ( mkVersion' ) import Distribution.System@@ -57,15 +61,11 @@ import qualified Text.PrettyPrint as Disp          ( Doc, render, char, text ) import Text.PrettyPrint-         ( (<+>), (<>) )+         ( (<+>) ) -import Data.List-         ( unfoldr, sortBy ) import Data.Char as Char          ( isAlpha, isAlphaNum ) -import Prelude hiding (show)- data BuildReport    = BuildReport {     -- | The package this build report is about@@ -173,7 +173,7 @@     arch            = requiredField "arch",     compiler        = requiredField "compiler",     client          = requiredField "client",-    flagAssignment  = [],+    flagAssignment  = mempty,     dependencies    = [],     installOutcome  = requiredField "install-outcome", --    cabalVersion  = Nothing,@@ -194,7 +194,7 @@  parseFields :: String -> ParseResult BuildReport parseFields input = do-  fields <- mapM extractField =<< readFields input+  fields <- traverse extractField =<< readFields input   let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)                        sortedFieldDescrs                        (sortBy (comparing (\(_,name,_) -> name)) fields)@@ -249,7 +249,8 @@  , simpleField "client"          Text.disp      Text.parse                                  client         (\v r -> r { client = v })  , listField   "flags"           dispFlag       parseFlag-                                 flagAssignment (\v r -> r { flagAssignment = v })+                                 (unFlagAssignment . flagAssignment)+                                 (\v r -> r { flagAssignment = mkFlagAssignment v })  , listField   "dependencies"    Text.disp      Text.parse                                  dependencies   (\v r -> r { dependencies = v })  , simpleField "install-outcome" Text.disp      Text.parse@@ -265,7 +266,7 @@  dispFlag :: (FlagName, Bool) -> Disp.Doc dispFlag (fname, True)  =                  Disp.text (unFlagName fname)-dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname)+dispFlag (fname, False) = Disp.char '-' <<>> Disp.text (unFlagName fname)  parseFlag :: Parse.ReadP r (FlagName, Bool) parseFlag = do

Distribution/Client/BuildReports/Storage.hs view

@@ -51,7 +51,7 @@ import Data.List          ( groupBy, sortBy ) import Data.Maybe-         ( catMaybes )+         ( mapMaybe ) import System.FilePath          ( (</>), takeDirectory ) import System.Directory@@ -126,10 +126,9 @@                 -> BuildOutcomes                 -> [(BuildReport, Maybe Repo)] fromInstallPlan platform comp plan buildOutcomes =-     catMaybes-   . map (\pkg -> fromPlanPackage-                    platform comp pkg-                    (InstallPlan.lookupBuildOutcome pkg buildOutcomes))+     mapMaybe (\pkg -> fromPlanPackage+                         platform comp pkg+                         (InstallPlan.lookupBuildOutcome pkg buildOutcomes))    . InstallPlan.toList    $ plan

Distribution/Client/Check.hs view

@@ -16,26 +16,42 @@     check   ) where -import Control.Monad ( when, unless )--#ifdef CABAL_PARSEC-import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse ( readGenericPackageDescription )-#endif+import Distribution.Client.Compat.Prelude+import Prelude () +import Distribution.PackageDescription               (GenericPackageDescription) import Distribution.PackageDescription.Check-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription )-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Simple.Utils-         ( defaultPackageDesc, toUTF8, wrapText )+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.PackageDescription.Parsec+       (parseGenericPackageDescription, runParseResult)+import Distribution.Parsec.Common                    (PWarning (..), showPError, showPWarning)+import Distribution.Simple.Utils                     (defaultPackageDesc, die', warn, wrapText)+import Distribution.Verbosity                        (Verbosity) +import qualified Data.ByteString  as BS+import qualified System.Directory as Dir++readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)+readGenericPackageDescriptionCheck verbosity fpath = do+    exists <- Dir.doesFileExist fpath+    unless exists $+      die' verbosity $+        "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."+    bs <- BS.readFile fpath+    let (warnings, result) = runParseResult (parseGenericPackageDescription bs)+    case result of+        Left (_, errors) -> do+            traverse_ (warn verbosity . showPError fpath) errors+            die' verbosity $ "Failed parsing \"" ++ fpath ++ "\"."+        Right x  -> return (warnings, x)+ check :: Verbosity -> IO Bool check verbosity = do     pdfile <- defaultPackageDesc verbosity-    ppd <- readGenericPackageDescription verbosity pdfile+    (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile+    -- convert parse warnings into PackageChecks+    -- Note: we /could/ pick different levels, based on warning type.+    let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ]     -- flatten the generic package description into a regular package     -- description     -- TODO: this may give more warnings than it should give;@@ -51,7 +67,7 @@     --      the exact same errors as it will.     let pkg_desc = flattenPackageDescription ppd     ioChecks <- checkPackageFiles pkg_desc "."-    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)+    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws'         buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]         buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]         distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]@@ -87,8 +103,8 @@     when (null packageChecks) $         putStrLn "No errors or warnings could be found in the package." -    return (null . filter isCheckError $ packageChecks)+    return (not . any isCheckError $ packageChecks)    where-    printCheckMessages = mapM_ (putStrLn . format . explanation)-    format = toUTF8 . wrapText . ("* "++)+    printCheckMessages = traverse_ (putStrLn . format . explanation)+    format = wrapText . ("* "++)

Distribution/Client/CmdBench.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ViewPatterns   #-}  -- | cabal-install CLI command: bench --@@ -18,8 +17,7 @@ import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault )@@ -77,7 +75,7 @@ -- benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)             -> [String] -> GlobalFlags -> IO ()-benchAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+benchAction (configFlags, configExFlags, installFlags, haddockFlags)             targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig@@ -105,10 +103,10 @@                          targetSelectors              let elaboratedPlan' = pruneInstallPlanToTargets-                                    TargetActionBuild+                                    TargetActionBench                                     targets                                     elaboratedPlan-            return elaboratedPlan'+            return (elaboratedPlan', targets)      printPlan verbosity baseCtx buildCtx @@ -127,7 +125,7 @@ -- For the @bench@ command we select all buildable benchmarks, -- or fail if there are no benchmarks or no buildable benchmarks. ---selectPackageTargets :: TargetSelector PackageId+selectPackageTargets :: TargetSelector                      -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -162,17 +160,20 @@ -- For the @bench@ command we just need to check it is a benchmark, in addition -- to the basic checks on being buildable etc. ---selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget+selectComponentTarget :: SubComponentTarget                       -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget pkgid cname subtarget@WholeComponent t+selectComponentTarget subtarget@WholeComponent t   | CBenchName _ <- availableTargetComponentName t   = either (Left . TargetProblemCommon) return $-           selectComponentTargetBasic pkgid cname subtarget t+           selectComponentTargetBasic subtarget t   | otherwise-  = Left (TargetProblemComponentNotBenchmark pkgid cname)+  = Left (TargetProblemComponentNotBenchmark (availableTargetPackageId t)+                                             (availableTargetComponentName t)) -selectComponentTarget pkgid cname subtarget _-  = Left (TargetProblemIsSubComponent pkgid cname subtarget)+selectComponentTarget subtarget t+  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)+                                      (availableTargetComponentName t)+                                       subtarget)  -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @bench@ command.@@ -181,13 +182,13 @@      TargetProblemCommon        TargetProblemCommon       -- | The 'TargetSelector' matches benchmarks but none are buildable-   | TargetProblemNoneEnabled  (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemNoneEnabled  TargetSelector [AvailableTarget ()]       -- | There are no targets at all-   | TargetProblemNoTargets    (TargetSelector PackageId)+   | TargetProblemNoTargets    TargetSelector       -- | The 'TargetSelector' matches targets but no benchmarks-   | TargetProblemNoBenchmarks (TargetSelector PackageId)+   | TargetProblemNoBenchmarks TargetSelector       -- | The 'TargetSelector' refers to a component that is not a benchmark    | TargetProblemComponentNotBenchmark PackageId ComponentName@@ -222,10 +223,6 @@            ++ renderTargetSelector targetSelector ++ "."        _ -> renderTargetProblemNoTargets "benchmark" targetSelector-  where-    targetSelectorFilter (TargetAllPackages  mkfilter) = mkfilter-    targetSelectorFilter (TargetPackage  _ _ mkfilter) = mkfilter-    targetSelectorFilter (TargetComponent _ _ _)       = Nothing  renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) =     "The bench command is for running benchmarks, but the target '"

Distribution/Client/CmdBuild.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE ViewPatterns #-}- -- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild (@@ -17,8 +15,7 @@ import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault )@@ -75,7 +72,7 @@ -- buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)             -> [String] -> GlobalFlags -> IO ()-buildAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+buildAction (configFlags, configExFlags, installFlags, haddockFlags)             targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig@@ -107,7 +104,7 @@                                                     elaboratedPlan'                 else return elaboratedPlan' -            return elaboratedPlan''+            return (elaboratedPlan'', targets)      printPlan verbosity baseCtx buildCtx @@ -126,7 +123,7 @@ -- For the @build@ command select all components except non-buildable and disabled -- tests\/benchmarks, fail if there are no such components ---selectPackageTargets :: TargetSelector PackageId+selectPackageTargets :: TargetSelector                      -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -159,11 +156,11 @@ -- -- For the @build@ command we just need the basic checks on being buildable etc. ---selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget+selectComponentTarget :: SubComponentTarget                       -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget pkgid cname subtarget =+selectComponentTarget subtarget =     either (Left . TargetProblemCommon) Right-  . selectComponentTargetBasic pkgid cname subtarget+  . selectComponentTargetBasic subtarget   -- | The various error conditions that can occur when matching a@@ -173,10 +170,10 @@      TargetProblemCommon       TargetProblemCommon       -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]       -- | There are no targets at all-   | TargetProblemNoTargets   (TargetSelector PackageId)+   | TargetProblemNoTargets   TargetSelector   deriving (Eq, Show)  reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a

Distribution/Client/CmdConfigure.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure (@@ -6,13 +5,16 @@     configureAction,   ) where +import System.Directory+import Control.Monad+import qualified Data.Map as Map+ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig          ( writeProjectLocalExtraConfig )  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault ) import Distribution.Verbosity@@ -21,7 +23,7 @@ import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Utils-         ( wrapText )+         ( wrapText, notice ) import qualified Distribution.Client.Setup as Client  configureCommand :: CommandUI (ConfigFlags, ConfigExFlags@@ -78,25 +80,30 @@ -- configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)                 -> [String] -> GlobalFlags -> IO ()-configureAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+configureAction (configFlags, configExFlags, installFlags, haddockFlags)                 _extraArgs globalFlags = do     --TODO: deal with _extraArgs, since flags with wrong syntax end up there      baseCtx <- establishProjectBaseContext verbosity cliConfig      -- Write out the @cabal.project.local@ so it gets picked up by the-    -- planning phase.+    -- planning phase. If old config exists, then print the contents+    -- before overwriting+    exists <- doesFileExist "cabal.project.local"+    when exists $ do+        notice verbosity "'cabal.project.local' file already exists. Now overwriting it."+        copyFile "cabal.project.local" "cabal.project.local~"     writeProjectLocalExtraConfig (distDirLayout baseCtx)                                  cliConfig      buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan ->              -- TODO: Select the same subset of targets as 'CmdBuild' would             -- pick (ignoring, for example, executables in libraries             -- we depend on). But we don't want it to fail, so actually we             -- have to do it slightly differently from build.-            return elaboratedPlan+            return (elaboratedPlan, Map.empty)      let baseCtx' = baseCtx {                       buildSettings = (buildSettings baseCtx) {

Distribution/Client/CmdErrorMessages.hs view

@@ -9,10 +9,10 @@  import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetSelector-         ( componentKind, showTargetSelector )+         ( ComponentKindFilter, componentKind, showTargetSelector )  import Distribution.Package-         ( packageId, packageName )+         ( packageId, PackageName, packageName ) import Distribution.Types.ComponentName          ( showComponentName ) import Distribution.Solver.Types.OptionalStanza@@ -84,14 +84,23 @@ -- Renderering for a few project and package types -- -renderTargetSelector :: TargetSelector PackageId -> String-renderTargetSelector (TargetPackage _ pkgid Nothing) =-    "the package " ++ display pkgid+renderTargetSelector :: TargetSelector -> String+renderTargetSelector (TargetPackage _ pkgids Nothing) =+    "the " ++ plural (listPlural pkgids) "package" "packages" ++ " "+ ++ renderListCommaAnd (map display pkgids) -renderTargetSelector (TargetPackage _ pkgid (Just kfilter)) =+renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) =     "the " ++ renderComponentKind Plural kfilter- ++ " in the package " ++ display pkgid+ ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " "+ ++ renderListCommaAnd (map display pkgids) +renderTargetSelector (TargetPackageNamed pkgname Nothing) =+    "the package " ++ display pkgname++renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) =+    "the " ++ renderComponentKind Plural kfilter+ ++ " in the package " ++ display pkgname+ renderTargetSelector (TargetAllPackages Nothing) =     "all the packages in the project" @@ -99,17 +108,24 @@     "all the " ++ renderComponentKind Plural kfilter  ++ " in the project" -renderTargetSelector (TargetComponent pkgid CLibName WholeComponent) =-    "the library in the package " ++ display pkgid+renderTargetSelector (TargetComponent pkgid cname subtarget) =+    renderSubComponentTarget subtarget ++ "the "+ ++ renderComponentName (packageName pkgid) cname -renderTargetSelector (TargetComponent _pkgid cname WholeComponent) =-    "the " ++ showComponentName cname+renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) =+    renderSubComponentTarget subtarget ++ "the component " ++ display ucname+ ++ " in the package " ++ display pkgname -renderTargetSelector (TargetComponent _pkgid cname (FileTarget filename)) =-    "the file " ++ filename ++ " in the " ++ showComponentName cname+renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) =+    renderSubComponentTarget subtarget ++ "the "+ ++ renderComponentName pkgname cname -renderTargetSelector (TargetComponent _pkgid cname (ModuleTarget modname)) =-    "the module " ++ display modname ++ " in the " ++ showComponentName cname+renderSubComponentTarget :: SubComponentTarget -> String+renderSubComponentTarget WholeComponent         = ""+renderSubComponentTarget (FileTarget filename)  =+  "the file " ++ filename ++ "in "+renderSubComponentTarget (ModuleTarget modname) =+  "the module" ++ display modname ++ "in "   renderOptionalStanza :: Plural -> OptionalStanza -> String@@ -124,20 +140,38 @@ optionalStanza (CBenchName _) = Just BenchStanzas optionalStanza _              = Nothing - -- | Does the 'TargetSelector' potentially refer to one package or many? ---targetSelectorPluralPkgs :: TargetSelector a -> Plural+targetSelectorPluralPkgs :: TargetSelector -> Plural targetSelectorPluralPkgs (TargetAllPackages _)     = Plural-targetSelectorPluralPkgs (TargetPackage _ _ _)     = Singular-targetSelectorPluralPkgs (TargetComponent _ _ _)   = Singular+targetSelectorPluralPkgs (TargetPackage _ pids _)  = listPlural pids+targetSelectorPluralPkgs (TargetPackageNamed _ _)  = Singular+targetSelectorPluralPkgs  TargetComponent{}        = Singular+targetSelectorPluralPkgs  TargetComponentUnknown{} = Singular --- | Does the 'TargetSelector' refer to -targetSelectorRefersToPkgs :: TargetSelector a -> Bool-targetSelectorRefersToPkgs (TargetAllPackages  mkfilter) = isNothing mkfilter-targetSelectorRefersToPkgs (TargetPackage  _ _ mkfilter) = isNothing mkfilter-targetSelectorRefersToPkgs (TargetComponent _ _ _)       = False+-- | Does the 'TargetSelector' refer to packages or to components?+targetSelectorRefersToPkgs :: TargetSelector -> Bool+targetSelectorRefersToPkgs (TargetAllPackages    mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs (TargetPackage    _ _ mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs  TargetComponent{}              = False+targetSelectorRefersToPkgs  TargetComponentUnknown{}       = False +targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter+targetSelectorFilter (TargetPackage    _ _ mkfilter) = mkfilter+targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter+targetSelectorFilter (TargetAllPackages    mkfilter) = mkfilter+targetSelectorFilter  TargetComponent{}              = Nothing+targetSelectorFilter  TargetComponentUnknown{}       = Nothing++renderComponentName :: PackageName -> ComponentName -> String+renderComponentName pkgname CLibName     = "library " ++ display pkgname+renderComponentName _ (CSubLibName name) = "library " ++ display name+renderComponentName _ (CFLibName   name) = "foreign library " ++ display name+renderComponentName _ (CExeName    name) = "executable " ++ display name+renderComponentName _ (CTestName   name) = "test suite " ++ display name+renderComponentName _ (CBenchName  name) = "benchmark " ++ display name+ renderComponentKind :: Plural -> ComponentKind -> String renderComponentKind Singular ckind = case ckind of   LibKind   -> "library"  -- internal/sub libs?@@ -197,7 +231,7 @@     "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "  ++ "solver did not find a plan that included the " ++ compkinds  ++ " for " ++ display pkgid ++ ". It is probably worth trying again with "- ++ compkinds ++ "explicitly enabled in the configuration in the "+ ++ compkinds ++ " explicitly enabled in the configuration in the "  ++ "cabal.project{.local} file. This will ask the solver to find a plan with "  ++ "the " ++ compkinds ++ " available. It will either fail with an "  ++ "explanation or find a different plan that uses different versions of some "@@ -206,6 +240,18 @@    where      compkinds = renderComponentKind Plural (componentKind cname) +renderTargetProblemCommon verb (TargetProblemUnknownComponent pkgname ecname) =+    "Cannot " ++ verb ++ " the "+ ++ (case ecname of+      Left ucname -> "component " ++ display ucname+      Right cname -> renderComponentName pkgname cname)+ ++ " from the package " ++ display pkgname+ ++ ", because the package does not contain a "+ ++ (case ecname of+      Left  _     -> "component"+      Right cname -> renderComponentKind Singular (componentKind cname))+ ++ " with that name."+ renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) =     "Internal error when trying to " ++ verb ++ " the package "   ++ display pkgid ++ ". The package is not in the set of available targets "@@ -228,7 +274,7 @@ -- This renders an error message for those cases. -- renderTargetProblemNoneEnabled :: String-                               -> TargetSelector PackageId+                               -> TargetSelector                                -> [AvailableTarget ()]                                -> String renderTargetProblemNoneEnabled verb targetSelector targets =@@ -290,7 +336,7 @@ -- | Several commands have a @TargetProblemNoTargets@ problem constructor. -- This renders an error message for those cases. ---renderTargetProblemNoTargets :: String -> TargetSelector PackageId -> String+renderTargetProblemNoTargets :: String -> TargetSelector -> String renderTargetProblemNoTargets verb targetSelector =     "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector  ++ " because " ++ reason targetSelector ++ ". "@@ -304,12 +350,18 @@         "it does not contain any components at all"     reason (TargetPackage _ _ (Just kfilter)) =         "it does not contain any " ++ renderComponentKind Plural kfilter+    reason (TargetPackageNamed _ Nothing) =+        "it does not contain any components at all"+    reason (TargetPackageNamed _ (Just kfilter)) =+        "it does not contain any " ++ renderComponentKind Plural kfilter     reason (TargetAllPackages Nothing) =         "none of them contain any components at all"     reason (TargetAllPackages (Just kfilter)) =         "none of the packages contain any "      ++ renderComponentKind Plural kfilter     reason ts@TargetComponent{} =+        error $ "renderTargetProblemNoTargets: " ++ show ts+    reason ts@TargetComponentUnknown{} =         error $ "renderTargetProblemNoTargets: " ++ show ts  -----------------------------------------------------------

+ Distribution/Client/CmdExec.hs view

@@ -0,0 +1,259 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Exec+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'new-exec' command for running an arbitrary executable+-- in an environment suited to the part of the store built for a project.+-------------------------------------------------------------------------------++{-# LANGUAGE RecordWildCards #-}+module Distribution.Client.CmdExec+  ( execAction+  , execCommand+  ) where++import Distribution.Client.DistDirLayout+  ( DistDirLayout(..)+  )+import Distribution.Client.InstallPlan+  ( GenericPlanPackage(..)+  , toGraph+  )+import Distribution.Client.Setup+  ( ConfigExFlags+  , ConfigFlags(configVerbosity)+  , GlobalFlags+  , InstallFlags+  )+import Distribution.Client.ProjectOrchestration+  ( ProjectBuildContext(..)+  , runProjectPreBuildPhase+  , establishProjectBaseContext+  , distDirLayout+  , commandLineFlagsToProjectConfig+  , ProjectBaseContext(..)+  )+import Distribution.Client.ProjectPlanOutput+  ( updatePostBuildProjectStatus+  , createPackageEnvironment+  , argsEquivalentOfGhcEnvironmentFile+  , PostBuildProjectStatus+  )+import qualified Distribution.Client.ProjectPlanning as Planning+import Distribution.Client.ProjectPlanning+  ( ElaboratedInstallPlan+  , ElaboratedSharedConfig(..)+  )+import Distribution.Simple.Command+  ( CommandUI(..)+  )+import Distribution.Simple.Program.Db+  ( modifyProgramSearchPath+  , requireProgram+  , configuredPrograms+  )+import Distribution.Simple.Program.Find+  ( ProgramSearchPathEntry(..)+  )+import Distribution.Simple.Program.Run+  ( programInvocation+  , runProgramInvocation+  )+import Distribution.Simple.Program.Types+  ( programOverrideEnv+  , programDefaultArgs+  , programPath+  , simpleProgram+  , ConfiguredProgram+  )+import Distribution.Simple.GHC+  ( getImplInfo+  , GhcImplInfo(supportsPkgEnvFiles) )+import Distribution.Simple.Setup+  ( HaddockFlags+  , fromFlagOrDefault+  )+import Distribution.Simple.Utils+  ( die'+  , info+  , withTempDirectory+  , wrapText+  )+import Distribution.Verbosity+  ( Verbosity+  , normal+  )++import qualified Distribution.Client.CmdBuild as CmdBuild++import Prelude ()+import Distribution.Client.Compat.Prelude++import Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Map as M++execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+execCommand = CommandUI+  { commandName = "new-exec"+  , commandSynopsis = "Give a command access to the store."+  , commandUsage = \pname ->+    "Usage: " ++ pname ++ " new-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"+    ++ " 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"+    ++ " to choose an appropriate version of ghc and to include any"+    ++ " ghc-specific flags requested."+  , commandNotes = Nothing+  , commandOptions = commandOptions CmdBuild.buildCommand+  , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand+  }++execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+           -> [String] -> GlobalFlags -> IO ()+execAction (configFlags, configExFlags, installFlags, haddockFlags)+           extraArgs globalFlags = do++  baseCtx <- establishProjectBaseContext verbosity cliConfig++  -- 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+  -- plan, but we walk the dependency tree without first executing the plan.+  buildCtx <- runProjectPreBuildPhase+    verbosity+    baseCtx+    (\plan -> return (plan, M.empty))++  -- We use the build status below to decide what libraries to include in the+  -- compiler environment, but we don't want to actually build anything. So we+  -- pass mempty to indicate that nothing happened and we just want the current+  -- status.+  buildStatus <- updatePostBuildProjectStatus+    verbosity+    (distDirLayout baseCtx)+    (elaboratedPlanOriginal buildCtx)+    (pkgsBuildStatus buildCtx)+    mempty++  -- Some dependencies may have executables. Let's put those on the PATH.+  extraPaths <- pathAdditions verbosity baseCtx buildCtx+  let programDb = modifyProgramSearchPath+                  (map ProgramSearchPathDir extraPaths ++)+                . pkgConfigCompilerProgs+                . elaboratedShared+                $ buildCtx++  -- Now that we have the packages, set up the environment. We accomplish this+  -- by creating an environment file that selects the databases and packages we+  -- computed in the previous step, and setting an environment variable to+  -- point at the file.+  -- In case ghc is too old to support environment files,+  -- we pass the same info as arguments+  let compiler = pkgConfigCompiler $ elaboratedShared buildCtx+      envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)+  case extraArgs of+    [] -> die' verbosity "Please specify an executable to run"+    exe:args -> do+      (program, _) <- requireProgram verbosity (simpleProgram exe) programDb+      let argOverrides =+            argsEquivalentOfGhcEnvironmentFile+              compiler+              (distDirLayout baseCtx)+              (elaboratedPlanOriginal buildCtx)+              buildStatus+          programIsConfiguredCompiler = matchCompilerPath+                                          (elaboratedShared buildCtx)+                                          program+          argOverrides' =+            if envFilesSupported+            || not programIsConfiguredCompiler+            then []+            else argOverrides++      (if envFilesSupported+      then withTempEnvFile verbosity baseCtx buildCtx buildStatus+      else \f -> f []) $ \envOverrides -> do+        let program'   = withOverrides+                           envOverrides+                           argOverrides'+                           program+            invocation = programInvocation program' args+        runProgramInvocation verbosity invocation+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags+    withOverrides env args program = program+      { programOverrideEnv = programOverrideEnv program ++ env+      , programDefaultArgs = programDefaultArgs program ++ args}++matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool+matchCompilerPath elaboratedShared program =+  programPath program+  `elem`+  (programPath <$> configuredCompilers)+  where+    configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared++-- | Execute an action with a temporary .ghc.environment file reflecting the+-- current environment. The action takes an environment containing the env+-- variable which points ghc to the file.+withTempEnvFile :: Verbosity+                -> ProjectBaseContext+                -> ProjectBuildContext+                -> PostBuildProjectStatus+                -> ([(String, Maybe String)] -> IO a)+                -> IO a+withTempEnvFile verbosity+                baseCtx+                buildCtx+                buildStatus+                action =+  withTempDirectory+   verbosity+   (distTempDirectory (distDirLayout baseCtx))+   "environment."+   (\tmpDir -> do+     envOverrides <- createPackageEnvironment+       verbosity+       tmpDir+       (elaboratedPlanToExecute buildCtx)+       (elaboratedShared buildCtx)+       buildStatus+     action envOverrides)++pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath]+pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do+  info verbosity . unlines $ "Including the following directories in PATH:"+                           : paths+  return paths+  where+  paths = S.toList+        $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute++binDirectories+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedInstallPlan+  -> Set FilePath+binDirectories layout config = fromElaboratedInstallPlan where+  fromElaboratedInstallPlan = fromGraph . toGraph+  fromGraph = foldMap fromPlan+  fromSrcPkg = S.fromList . Planning.binDirectories layout config++  fromPlan (PreExisting _) = mempty+  fromPlan (Configured pkg) = fromSrcPkg pkg+  fromPlan (Installed pkg) = fromSrcPkg pkg+

Distribution/Client/CmdFreeze.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns #-}+{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-}  -- | cabal-install CLI command: freeze --@@ -29,14 +29,13 @@          ( VersionRange, thisVersion          , unionVersionRanges, simplifyVersionRange ) import Distribution.PackageDescription-         ( FlagAssignment )+         ( FlagAssignment, nullFlagAssignment ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils-         ( die', notice )+         ( die', notice, wrapText ) import Distribution.Verbosity          ( normal ) @@ -47,8 +46,6 @@  import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives )-import Distribution.Simple.Utils-         ( wrapText ) import qualified Distribution.Client.Setup as Client  @@ -104,7 +101,7 @@ -- freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)              -> [String] -> GlobalFlags -> IO ()-freezeAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+freezeAction (configFlags, configExFlags, installFlags, haddockFlags)              extraArgs globalFlags = do      unless (null extraArgs) $@@ -175,7 +172,7 @@     versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]     versionConstraints =       Map.mapWithKey-        (\p v -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyVersion v),+        (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v),                    ConstraintSourceFreeze)])         versionRanges @@ -204,7 +201,7 @@         | InstallPlan.Configured elab <- InstallPlan.toList plan         , let flags   = elabFlagAssignment elab               pkgname = packageName elab-        , not (null flags) ]+        , not (nullFlagAssignment flags) ]      -- As described above, remove the version constraints on local packages,     -- but leave any flag constraints.

Distribution/Client/CmdHaddock.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ViewPatterns   #-}  -- | cabal-install CLI command: haddock --@@ -18,11 +17,10 @@ import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup-         ( HaddockFlags(..), fromFlagOrDefault, fromFlag )+         ( HaddockFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity@@ -73,7 +71,7 @@ -- haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)                  -> [String] -> GlobalFlags -> IO ()-haddockAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+haddockAction (configFlags, configExFlags, installFlags, haddockFlags)                 targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig@@ -102,7 +100,7 @@                                     TargetActionHaddock                                     targets                                     elaboratedPlan-            return elaboratedPlan'+            return (elaboratedPlan', targets)      printPlan verbosity baseCtx buildCtx @@ -122,7 +120,7 @@ -- depending on the @--executables@ flag we also select all the buildable exes. -- We do similarly for test-suites, benchmarks and foreign libs. ---selectPackageTargets  :: HaddockFlags -> TargetSelector PackageId+selectPackageTargets  :: HaddockFlags -> TargetSelector                       -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets haddockFlags targetSelector targets @@ -153,23 +151,30 @@     isRequested (TargetAllPackages (Just _)) _ = True     isRequested _ LibKind    = True --  isRequested _ SubLibKind = True --TODO: what about sublibs?-    isRequested _ FLibKind   = fromFlag (haddockForeignLibs haddockFlags)-    isRequested _ ExeKind    = fromFlag (haddockExecutables haddockFlags)-    isRequested _ TestKind   = fromFlag (haddockTestSuites  haddockFlags)-    isRequested _ BenchKind  = fromFlag (haddockBenchmarks  haddockFlags) +    -- TODO/HACK, we encode some defaults here as new-haddock's logic;+    -- make sure this matches the defaults applied in+    -- "Distribution.Client.ProjectPlanning"; this may need more work+    -- to be done properly+    --+    -- See also https://github.com/haskell/cabal/pull/4886+    isRequested _ FLibKind   = fromFlagOrDefault False (haddockForeignLibs haddockFlags)+    isRequested _ ExeKind    = fromFlagOrDefault False (haddockExecutables haddockFlags)+    isRequested _ TestKind   = fromFlagOrDefault False (haddockTestSuites  haddockFlags)+    isRequested _ BenchKind  = fromFlagOrDefault False (haddockBenchmarks  haddockFlags) + -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @haddock@ command we just need the basic checks on being buildable -- etc. ---selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget+selectComponentTarget :: SubComponentTarget                       -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget pkgid cname subtarget =+selectComponentTarget subtarget =     either (Left . TargetProblemCommon) Right-  . selectComponentTargetBasic pkgid cname subtarget+  . selectComponentTargetBasic subtarget   -- | The various error conditions that can occur when matching a@@ -179,10 +184,10 @@      TargetProblemCommon       TargetProblemCommon       -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]       -- | There are no targets at all-   | TargetProblemNoTargets   (TargetSelector PackageId)+   | TargetProblemNoTargets   TargetSelector   deriving (Eq, Show)  reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a

+ Distribution/Client/CmdInstall.hs view

@@ -0,0 +1,369 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++-- | cabal-install CLI command: build+--+module Distribution.Client.CmdInstall (+    -- * The @build@ CLI and action+    installCommand,+    installAction,++    -- * Internals exposed for testing+    TargetProblem(..),+    selectPackageTargets,+    selectComponentTarget+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Client.Types+         ( PackageSpecifier(NamedPackage), UnresolvedSourcePackage )+import Distribution.Client.ProjectPlanning.Types+         ( pkgConfigCompiler )+import Distribution.Client.ProjectConfig.Types+         ( ProjectConfig, ProjectConfigBuildOnly(..)+         , projectConfigLogsDir, projectConfigStoreDir, projectConfigShared+         , projectConfigBuildOnly, projectConfigDistDir+         , projectConfigConfigFile )+import Distribution.Client.Config+         ( defaultCabalDir )+import Distribution.Client.ProjectConfig+         ( readGlobalConfig, resolveBuildTimeSettings )+import Distribution.Client.DistDirLayout+         ( defaultDistDirLayout, distDirectory, mkCabalDirLayout+         , ProjectRoot(ProjectRootImplicit), distProjectCacheDirectory+         , storePackageDirectory, cabalStoreDirLayout )+import Distribution.Client.RebuildMonad+         ( runRebuild )+import Distribution.Client.InstallSymlink+         ( symlinkBinary )+import Distribution.Simple.Setup+         ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Compiler+         ( compilerId )+import Distribution.Types.PackageName+         ( mkPackageName )+import Distribution.Types.UnitId+         ( UnitId )+import Distribution.Types.UnqualComponentName+         ( UnqualComponentName, unUnqualComponentName )+import Distribution.Verbosity+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText, die', notice+         , withTempDirectory, createDirectoryIfMissingVerbose )++import qualified Data.Map as Map+import System.Directory ( getTemporaryDirectory, makeAbsolute )+import System.FilePath ( (</>) )++import qualified Distribution.Client.CmdBuild as CmdBuild++installCommand :: CommandUI (ConfigFlags, ConfigExFlags+                            ,InstallFlags, HaddockFlags)+installCommand = CommandUI+  { commandName         = "new-install"+  , commandSynopsis     = "Install packages."+  , commandUsage        = usageAlternatives+                          "new-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). "+    ++ "If you want the installed executables to be available globally, "+    ++ "make sure that the PATH environment variable contains that directory. "+    ++ "\n\n"+    ++ "If TARGET is a library, it will be added to the global environment. "+    ++ "When doing this, cabal will try to build a plan that includes all "+    ++ "the previously installed libraries. This is currently not implemented."+  , commandNotes        = Just $ \pname ->+      "Examples:\n"+      ++ "  " ++ pname ++ " new-install\n"+      ++ "    Install the package in the current directory\n"+      ++ "  " ++ pname ++ " new-install pkgname\n"+      ++ "    Install the package named pkgname"+      ++ " (fetching it from hackage if necessary)\n"+      ++ "  " ++ pname ++ " new-install ./pkgfoo\n"+      ++ "    Install the package in the ./pkgfoo directory\n"++      ++ cmdCommonHelpTextNewBuildBeta+  , commandOptions = commandOptions CmdBuild.buildCommand+  , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand+  }+++-- | The @install@ command actually serves four different needs. It installs:+-- * Nonlocal exes:+--   For example a program from hackage. The behavior is similar to the old+--   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.+--   To do this we need a dummy projectBaseContext containing the targets as+--   estra packages and using a temporary dist directory.+-- * Nonlocal libraries (TODO see #4558)+-- * Local exes         (TODO see #4558)+-- * Local libraries    (TODO see #4558)+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+            -> [String] -> GlobalFlags -> IO ()+installAction (configFlags, configExFlags, installFlags, haddockFlags)+            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+  -- enabled.+  when (configTests configFlags' == Flag True) $+    die' verbosity $ "--enable-tests was specified, but tests can't "+                  ++ "be enabled in a remote package"+  when (configBenchmarks configFlags' == Flag True) $+    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "+                  ++ "be enabled in a remote package"++  -- We need a place to put a temporary dist directory+  globalTmp <- getTemporaryDirectory+  withTempDirectory+    verbosity+    globalTmp+    "cabal-install."+    $ \tmpDir -> do++    let packageNames = mkPackageName <$> targetStrings+        packageSpecifiers =+          (\pname -> NamedPackage pname []) <$> packageNames++    baseCtx <- establishDummyProjectBaseContext+                 verbosity+                 cliConfig+                 tmpDir+                 packageSpecifiers++    let targetSelectors = [ TargetPackageNamed pn Nothing+                          | pn <- packageNames ]++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do++            -- Interpret the targets on the command line as build targets+            targets <- either (reportTargetProblems verbosity) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         TargetProblemCommon+                         elaboratedPlan+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBuild+                                    targets+                                    elaboratedPlan+            elaboratedPlan'' <-+              if buildSettingOnlyDeps (buildSettings baseCtx)+                then either (reportCannotPruneDependencies verbosity) return $+                     pruneInstallPlanToDependencies (Map.keysSet targets)+                                                    elaboratedPlan'+                else return elaboratedPlan'++            return (elaboratedPlan'', targets)++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx++    let compiler = pkgConfigCompiler $ elaboratedShared buildCtx+    let mkPkgBinDir = (</> "bin") .+                      storePackageDirectory+                         (cabalStoreDirLayout $ cabalDirLayout baseCtx)+                         (compilerId compiler)++    -- 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+    traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir)+          $ Map.toList $ targetsMap buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    configFlags' = disableTestsBenchsByDefault configFlags+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags' configExFlags+                  installFlags haddockFlags+++-- | Disables tests and benchmarks if they weren't explicitly enabled.+disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags+disableTestsBenchsByDefault configFlags =+  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+                    -> (UnitId -> FilePath) -- ^ A function to get an UnitId's+                                            -- store directory+                    -> FilePath -- ^ Where to put the symlink+                    -> ( UnitId+                        , [(ComponentTarget, [TargetSelector])] )+                     -> IO ()+symlinkBuiltPackage verbosity mkSourceBinDir destDir (pkg, components) =+  traverse_ (symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir) exes+  where+    exes = catMaybes $ (exeMaybe . fst) <$> components+    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe+    exeMaybe _ = Nothing++-- | Symlink a specific exe.+symlinkBuiltExe :: Verbosity -> FilePath -> FilePath -> UnqualComponentName -> IO Bool+symlinkBuiltExe verbosity sourceDir destDir exe = do+  notice verbosity $ "Symlinking " ++ unUnqualComponentName exe+  symlinkBinary+    destDir+    sourceDir+    exe+    $ unUnqualComponentName exe++-- | Create a dummy project context, without a .cabal or a .cabal.project file+-- (a place where to put a temporary dist directory is still needed)+establishDummyProjectBaseContext+  :: Verbosity+  -> ProjectConfig+  -> FilePath+     -- ^ Where to put the dist directory+  -> [PackageSpecifier UnresolvedSourcePackage]+     -- ^ The packages to be included in the project+  -> IO ProjectBaseContext+establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do++    cabalDir <- defaultCabalDir++    -- Create the dist directories+    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout+    createDirectoryIfMissingVerbose verbosity True $+      distProjectCacheDirectory distDirLayout++    globalConfig <- runRebuild ""+                  $ readGlobalConfig verbosity+                  $ projectConfigConfigFile+                  $ projectConfigShared cliConfig+    let projectConfig = globalConfig <> cliConfig++    let ProjectConfigBuildOnly {+          projectConfigLogsDir,+          projectConfigStoreDir+        } = projectConfigBuildOnly projectConfig++        mlogsDir = flagToMaybe projectConfigLogsDir+        mstoreDir = flagToMaybe projectConfigStoreDir+        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir++        buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++    return ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages,+      buildSettings+    }+  where+    mdistDirectory = flagToMaybe+                   $ projectConfigDistDir+                   $ projectConfigShared cliConfig+    projectRoot = ProjectRootImplicit tmpDir+    distDirLayout = defaultDistDirLayout projectRoot+                                         mdistDirectory++-- | 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+--+selectPackageTargets :: TargetSelector+                     -> [AvailableTarget k] -> Either TargetProblem [k]+selectPackageTargets targetSelector targets++    -- If there are any buildable targets then we select those+  | not (null targetsBuildable)+  = Right targetsBuildable++    -- If there are targets but none are buildable then we report those+  | not (null targets)+  = Left (TargetProblemNoneEnabled targetSelector targets')++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    targets'         = forgetTargetsDetail targets+    targetsBuildable = selectBuildableTargetsWith+                         (buildable targetSelector)+                         targets++    -- When there's a target filter like "pkg:tests" then we do select tests,+    -- but if it's just a target like "pkg" then we don't build tests unless+    -- they are requested by default (i.e. by using --enable-tests)+    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False+    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False+    buildable _ _ = True++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @build@ command we just need the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem k+selectComponentTarget subtarget =+    either (Left . TargetProblemCommon) Right+  . selectComponentTargetBasic subtarget+++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @build@ command.+--+data TargetProblem =+     TargetProblemCommon       TargetProblemCommon++     -- | The 'TargetSelector' matches targets but none are buildable+   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]++     -- | There are no targets at all+   | TargetProblemNoTargets   TargetSelector+  deriving (Eq, Show)++reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderTargetProblem++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (TargetProblemCommon problem) =+    renderTargetProblemCommon "build" problem+renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled "build" targetSelector targets+renderTargetProblem(TargetProblemNoTargets targetSelector) =+    renderTargetProblemNoTargets "build" targetSelector++reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a+reportCannotPruneDependencies verbosity =+    die' verbosity . renderCannotPruneDependencies

Distribution/Client/CmdRepl.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ViewPatterns   #-}  -- | cabal-install CLI command: repl --@@ -18,8 +17,7 @@ import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault )@@ -89,7 +87,7 @@ -- replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)            -> [String] -> GlobalFlags -> IO ()-replAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+replAction (configFlags, configExFlags, installFlags, haddockFlags)            targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig@@ -126,7 +124,7 @@                                     TargetActionRepl                                     targets                                     elaboratedPlan-            return elaboratedPlan'+            return (elaboratedPlan', targets)      printPlan verbosity baseCtx buildCtx @@ -153,7 +151,7 @@ -- Fail if there are no buildable lib\/exe components, or if there are -- multiple libs or exes. ---selectPackageTargets  :: TargetSelector PackageId+selectPackageTargets  :: TargetSelector                       -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -215,11 +213,11 @@ -- -- For the @repl@ command we just need the basic checks on being buildable etc. ---selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget+selectComponentTarget :: SubComponentTarget                       -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget pkgid cname subtarget =+selectComponentTarget subtarget =     either (Left . TargetProblemCommon) Right-  . selectComponentTargetBasic pkgid cname subtarget+  . selectComponentTargetBasic subtarget   -- | The various error conditions that can occur when matching a@@ -229,13 +227,13 @@      TargetProblemCommon       TargetProblemCommon       -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]       -- | There are no targets at all-   | TargetProblemNoTargets   (TargetSelector PackageId)+   | TargetProblemNoTargets   TargetSelector       -- | A single 'TargetSelector' matches multiple targets-   | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]       -- | Multiple 'TargetSelector's match multiple targets    | TargetProblemMultipleTargets TargetsMap

Distribution/Client/CmdRun.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ViewPatterns   #-}  -- | cabal-install CLI command: run --@@ -14,29 +13,46 @@     selectComponentTarget   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Command          ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName-         ( componentNameString )+         ( showComponentName ) import Distribution.Text          ( display ) import Distribution.Verbosity          ( Verbosity, normal ) import Distribution.Simple.Utils-         ( wrapText, die', ordNub )+         ( wrapText, die', ordNub, info )+import Distribution.Client.ProjectPlanning+         ( ElaboratedConfiguredPackage(..)+         , ElaboratedInstallPlan, binDirectoryFor )+import Distribution.Client.ProjectPlanning.Types+         ( dataDirsEnvironmentForPlan )+import Distribution.Client.InstallPlan+         ( toList, foldPlanPackage )+import Distribution.Types.UnqualComponentName+         ( UnqualComponentName, unUnqualComponentName )+import Distribution.Simple.Program.Run+         ( runProgramInvocation, ProgramInvocation(..),+           emptyProgramInvocation )+import Distribution.Types.UnitId+         ( UnitId )  import qualified Data.Map as Map import qualified Data.Set as Set-import Control.Monad (when)+import System.FilePath+         ( (</>) )   runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)@@ -46,12 +62,13 @@   commandUsage        = usageAlternatives "new-run"                           [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ],   commandDescription  = Just $ \pname -> wrapText $-        "Runs the specified executable, first ensuring it is up to date.\n\n"+        "Runs the specified executable-like component (an executable, a test, "+     ++ "or a benchmark), first ensuring it is up to date.\n\n" -     ++ "Any executable in any package in the project can be specified. "-     ++ "A package can be specified if contains just one executable. "-     ++ "The default is to use the package in the current directory if it "-     ++ "contains just one executable.\n\n"+     ++ "Any executable-like component in any package in the project can be "+     ++ "specified. A package can be specified if contains just one "+     ++ "executable-like. The default is to use the package in the current "+     ++ "directory if it contains just one executable-like.\n\n"       ++ "Extra arguments can be passed to the program, but use '--' to "      ++ "separate arguments for the program from arguments for " ++ pname@@ -65,11 +82,11 @@   commandNotes        = Just $ \pname ->         "Examples:\n"      ++ "  " ++ pname ++ " new-run\n"-     ++ "    Run the executable in the package in the current directory\n"+     ++ "    Run the executable-like in the package in the current directory\n"      ++ "  " ++ pname ++ " new-run foo-tool\n"-     ++ "    Run the named executable (in any package in the project)\n"+     ++ "    Run the named executable-like (in any package in the project)\n"      ++ "  " ++ pname ++ " new-run pkgfoo:foo-tool\n"-     ++ "    Run the executable 'foo-tool' in the package 'pkgfoo'\n"+     ++ "    Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"      ++ "  " ++ pname ++ " new-run foo -O2 -- dothing --fooflag\n"      ++ "    Build with '-O2' and run the program, passing it extra arguments.\n\n" @@ -77,22 +94,24 @@    }  --- | The @build@ command does a lot. It brings the install plan up to date,--- selects that part of the plan needed by the given or implicit targets and--- then executes the plan.+-- | 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+-- exes/tests/benchs by simply appending them after a @--@. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)           -> [String] -> GlobalFlags -> IO ()-runAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+runAction (configFlags, configExFlags, installFlags, haddockFlags)             targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig      targetSelectors <- either (reportTargetSelectorProblems verbosity) return-                   =<< readTargetSelectors (localPackages baseCtx) targetStrings+                   =<< readTargetSelectors (localPackages baseCtx)+                         (take 1 targetStrings) -- Drop the exe's args.      buildCtx <-       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do@@ -116,26 +135,112 @@             -- Reject multiple targets, or at least targets in different             -- components. It is ok to have two module/file targets in the             -- same component, but not two that live in different components.-            when (Set.size (distinctTargetComponents targets) > 1) $-              reportTargetProblems verbosity-                [TargetProblemMultipleTargets targets]+            --+            -- Note that we discard the target and return the whole 'TargetsMap',+            -- so this check will be repeated (and must succeed) after+            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.+            _ <- singleExeOrElse+                   (reportTargetProblems+                      verbosity+                      [TargetProblemMultipleTargets targets])+                   targets              let elaboratedPlan' = pruneInstallPlanToTargets                                     TargetActionBuild                                     targets                                     elaboratedPlan-            return elaboratedPlan'+            return (elaboratedPlan', targets) +    (selectedUnitId, selectedComponent) <-+      -- Slight duplication with 'runProjectPreBuildPhase'.+      singleExeOrElse+        (die' verbosity $ "No or multiple targets given, but the run "+                       ++ "phase has been reached. This is a bug.")+        $ targetsMap buildCtx+     printPlan verbosity baseCtx buildCtx      buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+++    let elaboratedPlan = elaboratedPlanToExecute buildCtx+        matchingElaboratedConfiguredPackages =+          matchingPackagesByUnitId+            selectedUnitId+            elaboratedPlan++    let exeName = unUnqualComponentName selectedComponent++    -- In the common case, we expect @matchingElaboratedConfiguredPackages@+    -- to consist of a single element that provides a single way of building+    -- an appropriately-named executable. In that case we take that+    -- package and continue.+    --+    -- However, multiple packages/components could provide that+    -- executable, or it's possible we don't find the executable anywhere+    -- in the build plan. I suppose in principle it's also possible that+    -- a single package provides an executable in two different ways,+    -- though that's probably a bug if. Anyway it's a good lint to report+    -- an error in all of these cases, even if some seem like they+    -- shouldn't happen.+    pkg <- case matchingElaboratedConfiguredPackages of+      [] -> die' verbosity $ "Unknown executable "+                          ++ exeName+                          ++ " in package "+                          ++ display selectedUnitId+      [elabPkg] -> do+        info verbosity $ "Selecting "+                       ++ display selectedUnitId+                       ++ " to supply " ++ exeName+        return elabPkg+      elabPkgs -> die' verbosity+        $ "Multiple matching executables found matching "+        ++ exeName+        ++ ":\n"+        ++ unlines (fmap (\p -> " - in package " ++ display (elabUnitId p)) elabPkgs)+    let exePath = binDirectoryFor (distDirLayout baseCtx)+                                  (elaboratedShared buildCtx)+                                  pkg+                                  exeName+               </> exeName+    let args = drop 1 targetStrings+    runProgramInvocation+      verbosity+      emptyProgramInvocation {+        progInvokePath  = exePath,+        progInvokeArgs  = args,+        progInvokeEnv   = dataDirsEnvironmentForPlan elaboratedPlan+      }   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)     cliConfig = commandLineFlagsToProjectConfig                   globalFlags configFlags configExFlags                   installFlags haddockFlags +singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)+singleExeOrElse action targetsMap =+  case Set.toList . distinctTargetComponents $ targetsMap+  of [(unitId, CExeName component)] -> return (unitId, component)+     [(unitId, CTestName component)] -> return (unitId, component)+     [(unitId, CBenchName component)] -> return (unitId, component)+     _   -> action++-- | Filter the 'ElaboratedInstallPlan' keeping only the+-- 'ElaboratedConfiguredPackage's that match the specified+-- 'UnitId'.+matchingPackagesByUnitId :: UnitId+                         -> ElaboratedInstallPlan+                         -> [ElaboratedConfiguredPackage]+matchingPackagesByUnitId uid =+          catMaybes+          . fmap (foldPlanPackage+                    (const Nothing)+                    (\x -> if elabUnitId x == uid+                           then Just x+                           else Nothing))+          . toList+ -- | This defines what a 'TargetSelector' means for the @run@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem.@@ -143,7 +248,7 @@ -- For the @run@ command we select the exe if there is only one and it's -- buildable. Fail if there are no or multiple buildable exe components. ---selectPackageTargets :: TargetSelector PackageId+selectPackageTargets :: TargetSelector                      -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -167,33 +272,40 @@   | otherwise   = Left (TargetProblemNoTargets targetSelector)   where+    -- Targets that can be executed+    targetsExecutableLike =+      concatMap (\kind -> filterTargetsKind kind targets)+                [ExeKind, TestKind, BenchKind]     (targetsExesBuildable,-     targetsExesBuildable') = selectBuildableTargets'-                            . filterTargetsKind ExeKind-                            $ targets+     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike -    targetsExes             = forgetTargetsDetail-                            . filterTargetsKind ExeKind-                            $ targets+    targetsExes             = forgetTargetsDetail targetsExecutableLike   -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. ----- For the @run@ command we just need to check it is a executable, in addition+-- For the @run@ command we just need to check it is a executable-like+-- (an executable, a test, or a benchmark), in addition -- to the basic checks on being buildable etc. ---selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget+selectComponentTarget :: SubComponentTarget                       -> AvailableTarget k -> Either TargetProblem  k-selectComponentTarget pkgid cname subtarget@WholeComponent t-  | CExeName _ <- availableTargetComponentName t-  = either (Left . TargetProblemCommon) return $-           selectComponentTargetBasic pkgid cname subtarget t-  | otherwise-  = Left (TargetProblemComponentNotExe pkgid cname)+selectComponentTarget subtarget@WholeComponent t+  = case availableTargetComponentName t+    of CExeName _ -> component+       CTestName _ -> component+       CBenchName _ -> component+       _ -> Left (TargetProblemComponentNotExe pkgid cname)+    where pkgid = availableTargetPackageId t+          cname = availableTargetComponentName t+          component = either (Left . TargetProblemCommon) return $+                        selectComponentTargetBasic subtarget t -selectComponentTarget pkgid cname subtarget _-  = Left (TargetProblemIsSubComponent pkgid cname subtarget)+selectComponentTarget subtarget t+  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)+                                      (availableTargetComponentName t)+                                       subtarget)  -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @run@ command.@@ -201,16 +313,16 @@ data TargetProblem =      TargetProblemCommon       TargetProblemCommon      -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]       -- | There are no targets at all-   | TargetProblemNoTargets   (TargetSelector PackageId)+   | TargetProblemNoTargets   TargetSelector       -- | The 'TargetSelector' matches targets but no executables-   | TargetProblemNoExes      (TargetSelector PackageId)+   | TargetProblemNoExes      TargetSelector       -- | A single 'TargetSelector' matches multiple targets-   | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]       -- | Multiple 'TargetSelector's match multiple targets    | TargetProblemMultipleTargets TargetsMap@@ -248,21 +360,17 @@            ++ renderTargetSelector targetSelector ++ "."        _ -> renderTargetProblemNoTargets "run" targetSelector-  where-    targetSelectorFilter (TargetPackage  _ _ mkfilter) = mkfilter-    targetSelectorFilter (TargetAllPackages  mkfilter) = mkfilter-    targetSelectorFilter (TargetComponent _ _ _)       = Nothing - renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) =     "The run command is for running a single executable at once. The target '"  ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " which includes the executables "- ++ renderListCommaAnd-      [ display name-      | cname@CExeName{} <- map availableTargetComponentName targets-      , let Just name = componentNameString cname-      ]+ ++ renderTargetSelector targetSelector ++ " which includes "+ ++ renderListCommaAnd ( ("the "++) <$>+                         showComponentName <$>+                         availableTargetComponentName <$>+                         foldMap+                           (\kind -> filterTargetsKind kind targets)+                           [ExeKind, TestKind, BenchKind] )  ++ "."  renderTargetProblem (TargetProblemMultipleTargets selectorMap) =@@ -286,4 +394,3 @@  ++ renderTargetSelector targetSelector ++ "."   where     targetSelector = TargetComponent pkgid cname subtarget-

Distribution/Client/CmdTest.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ViewPatterns   #-}  -- | cabal-install CLI command: test --@@ -18,8 +17,7 @@ import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags-         , applyFlagDefaults )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault )@@ -80,7 +78,7 @@ -- testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)            -> [String] -> GlobalFlags -> IO ()-testAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+testAction (configFlags, configExFlags, installFlags, haddockFlags)            targetStrings globalFlags = do      baseCtx <- establishProjectBaseContext verbosity cliConfig@@ -111,7 +109,7 @@                                     TargetActionTest                                     targets                                     elaboratedPlan-            return elaboratedPlan'+            return (elaboratedPlan', targets)      printPlan verbosity baseCtx buildCtx @@ -130,7 +128,7 @@ -- For the @test@ command we select all buildable test-suites, -- or fail if there are no test-suites or no buildable test-suites. ---selectPackageTargets  :: TargetSelector PackageId+selectPackageTargets  :: TargetSelector                       -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -165,17 +163,20 @@ -- For the @test@ command we just need to check it is a test-suite, in addition -- to the basic checks on being buildable etc. ---selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget+selectComponentTarget :: SubComponentTarget                       -> AvailableTarget k -> Either TargetProblem k-selectComponentTarget pkgid cname subtarget@WholeComponent t+selectComponentTarget subtarget@WholeComponent t   | CTestName _ <- availableTargetComponentName t   = either (Left . TargetProblemCommon) return $-           selectComponentTargetBasic pkgid cname subtarget t+           selectComponentTargetBasic subtarget t   | otherwise-  = Left (TargetProblemComponentNotTest pkgid cname)+  = Left (TargetProblemComponentNotTest (availableTargetPackageId t)+                                        (availableTargetComponentName t)) -selectComponentTarget pkgid cname subtarget _-  = Left (TargetProblemIsSubComponent pkgid cname subtarget)+selectComponentTarget subtarget t+  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)+                                      (availableTargetComponentName t)+                                       subtarget)  -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @test@ command.@@ -184,13 +185,13 @@      TargetProblemCommon       TargetProblemCommon       -- | The 'TargetSelector' matches targets but none are buildable-   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]+   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]       -- | There are no targets at all-   | TargetProblemNoTargets   (TargetSelector PackageId)+   | TargetProblemNoTargets   TargetSelector       -- | The 'TargetSelector' matches targets but no test-suites-   | TargetProblemNoTests     (TargetSelector PackageId)+   | TargetProblemNoTests     TargetSelector       -- | The 'TargetSelector' refers to a component that is not a test-suite    | TargetProblemComponentNotTest PackageId ComponentName@@ -225,10 +226,6 @@            ++ renderTargetSelector targetSelector ++ "."        _ -> renderTargetProblemNoTargets "test" targetSelector-  where-    targetSelectorFilter (TargetPackage  _ _ mkfilter) = mkfilter-    targetSelectorFilter (TargetAllPackages  mkfilter) = mkfilter-    targetSelectorFilter (TargetComponent _ _ _)       = Nothing  renderTargetProblem (TargetProblemComponentNotTest pkgid cname) =     "The test command is for running test suites, but the target '"

+ Distribution/Client/CmdUpdate.hs view

@@ -0,0 +1,212 @@+{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns,+             TupleSections #-}++-- | cabal-install CLI command: update+--+module Distribution.Client.CmdUpdate (+    updateCommand,+    updateAction,+  ) where++import Distribution.Client.Compat.Directory+         ( setModificationTime )+import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig+         ( ProjectConfig(..)+         , projectConfigWithSolverRepoContext )+import Distribution.Client.Types+         ( Repo(..), RemoteRepo(..), isRepoRemote )+import Distribution.Client.HttpUtils+         ( DownloadResult(..) )+import Distribution.Client.FetchUtils+         ( downloadIndex )+import Distribution.Client.JobControl+         ( newParallelJobControl, spawnJob, collectJob )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , UpdateFlags, defaultUpdateFlags+         , RepoContext(..) )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, intercalate )+import Distribution.Verbosity+         ( Verbosity, normal, lessVerbose )+import Distribution.Client.IndexUtils.Timestamp+import Distribution.Client.IndexUtils+         ( updateRepoIndexCache, Index(..), writeIndexTimestamp+         , currentIndexTimestamp, indexBaseName )+import Distribution.Text+         ( Text(..), display, simpleParse )++import Data.Maybe (fromJust)+import qualified Distribution.Compat.ReadP  as ReadP+import qualified Text.PrettyPrint           as Disp++import Control.Monad (unless, when)+import qualified Data.ByteString.Lazy       as BS+import Distribution.Client.GZipUtils (maybeDecompress)+import System.FilePath ((<.>), dropExtension)+import Data.Time (getCurrentTime)+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import qualified Distribution.Client.Setup as Client++import qualified Hackage.Security.Client as Sec++updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags+                           , InstallFlags, HaddockFlags )+updateCommand = Client.installCommand {+  commandName         = "new-update",+  commandSynopsis     = "Updates list of known packages.",+  commandUsage        = usageAlternatives "new-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"+     ++ "    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"+     ++ "    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"+     ++ "    head.hackage must be a known repo-id. E.g. from\n"+     ++ "    your cabal.project(.local) file.\n\n"+     ++ "Note: this command is part of the new project-based system (aka "+     ++ "nix-style\nlocal builds). These features are currently in beta. "+     ++ "Please see\n"+     ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "+     ++ "for\ndetails and advice on what you can expect to work. If you "+     ++ "encounter problems\nplease file issues at "+     ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "+     ++ "to get involved and help with testing, fixing bugs etc then\nthat "+     ++ "is very much appreciated.\n"+  }++data UpdateRequest = UpdateRequest+  { _updateRequestRepoName :: String+  , _updateRequestRepoState :: IndexState+  } deriving (Show)++instance Text UpdateRequest where+  disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s+  parse = parseWithState ReadP.+++ parseHEAD+    where parseWithState = do+            name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ','))+            _ <- ReadP.char ','+            state <- parse+            return (UpdateRequest name state)+          parseHEAD = do+            name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof+            return (UpdateRequest name IndexStateHead)++updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+             -> [String] -> GlobalFlags -> IO ()+updateAction (configFlags, configExFlags, installFlags, haddockFlags)+             extraArgs globalFlags = do++  ProjectBaseContext {+    projectConfig+  } <- establishProjectBaseContext verbosity cliConfig++  projectConfigWithSolverRepoContext verbosity+    (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)+    $ \repoCtxt -> do+    let repos       = filter isRepoRemote $ repoContextRepos repoCtxt+        repoName    = remoteRepoName . repoRemote+        parseArg :: String -> IO UpdateRequest+        parseArg s = case simpleParse s of+          Just r -> return r+          Nothing -> die' verbosity $+                     "'new-update' unable to parse repo: \"" ++ s ++ "\""+    updateRepoRequests <- mapM parseArg extraArgs++    unless (null updateRepoRequests) $ do+      let remoteRepoNames = map repoName repos+          unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests+                            , not (r `elem` remoteRepoNames)]+      unless (null unknownRepos) $+        die' verbosity $ "'new-update' repo(s): \""+                         ++ intercalate "\", \"" unknownRepos+                         ++ "\" can not be found in known remote repo(s): "+                         ++ intercalate ", " remoteRepoNames++    let reposToUpdate :: [(Repo, IndexState)]+        reposToUpdate = case updateRepoRequests of+          -- If we are not given any specific repository, update all+          -- repositories to HEAD.+          [] -> map (,IndexStateHead) repos+          updateRequests -> let repoMap = [(repoName r, r) | r <- repos]+                                lookup' k = fromJust (lookup k repoMap)+                            in [ (lookup' name, state)+                               | (UpdateRequest name state) <- updateRequests ]++    case reposToUpdate of+      [] -> return ()+      [(remoteRepo, _)] ->+        notice verbosity $ "Downloading the latest package list from "+                        ++ repoName remoteRepo+      _ -> notice verbosity . unlines+              $ "Downloading the latest package lists from: "+              : map (("- " ++) . repoName . fst) reposToUpdate++    jobCtrl <- newParallelJobControl (length reposToUpdate)+    mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)+      reposToUpdate+    mapM_ (\_ -> collectJob jobCtrl) reposToUpdate++  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags++updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState)+           -> IO ()+updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do+  transport <- repoContextGetTransport repoCtxt+  case repo of+    RepoLocal{..} -> return ()+    RepoRemote{..} -> do+      downloadResult <- downloadIndex transport verbosity+                        repoRemote repoLocalDir+      case downloadResult of+        FileAlreadyInCache ->+          setModificationTime (indexBaseName repo <.> "tar")+          =<< getCurrentTime+        FileDownloaded indexPath -> do+          writeFileAtomic (dropExtension indexPath) . maybeDecompress+                                                  =<< BS.readFile indexPath+          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do+      let index = RepoIndex repoCtxt repo+      -- NB: This may be a nullTimestamp if we've never updated before+      current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo+      -- NB: always update the timestamp, even if we didn't actually+      -- download anything+      writeIndexTimestamp index indexState+      ce <- if repoContextIgnoreExpiry repoCtxt+              then Just `fmap` getCurrentTime+              else return Nothing+      updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce+      -- Update cabal's internal index as well so that it's not out of sync+      -- (If all access to the cache goes through hackage-security this can go)+      case updated of+        Sec.NoUpdates  ->+          setModificationTime (indexBaseName repo <.> "tar")+          =<< getCurrentTime+        Sec.HasUpdates ->+          updateRepoIndexCache verbosity index+      -- TODO: This will print multiple times if there are multiple+      -- repositories: main problem is we don't have a way of updating+      -- a specific repo.  Once we implement that, update this.+      when (current_ts /= nullTimestamp) $+        noticeNoWrap verbosity $+          "To revert to previous state run:\n" +++          "    cabal new-update '" ++ remoteRepoName (repoRemote repo)+          ++ "," ++ display current_ts ++ "'\n"

+ Distribution/Client/Compat/Directory.hs view

@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+module Distribution.Client.Compat.Directory (setModificationTime) where++#if MIN_VERSION_directory(1,2,3)+import System.Directory (setModificationTime)+#else++import Data.Time.Clock (UTCTime)++setModificationTime :: FilePath -> UTCTime -> IO ()+setModificationTime _fp _t = return ()++#endif

Distribution/Client/Compat/FileLock.hsc view

@@ -74,17 +74,14 @@  #endif /* !defined(solaris2_HOST_OS) */ -#endif /* MIN_VERSION_base */ --#if !(MIN_VERSION_base(4,10,0))- -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported   deriving (Typeable, Show)  instance Exception FileLockingNotSupported+  -- | Indicates a mode in which a file should be locked. data LockMode = SharedLock | ExclusiveLock

Distribution/Client/Compat/FilePerms.hs view

@@ -12,9 +12,8 @@ import System.Posix.Internals          ( c_chmod ) import Foreign.C-         ( withCString )-import Foreign.C-         ( throwErrnoPathIfMinus1_ )+         ( withCString+         , throwErrnoPathIfMinus1_ ) #else import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN) #endif /* mingw32_HOST_OS */

Distribution/Client/Compat/Semaphore.hs view

@@ -10,7 +10,7 @@ import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,                                writeTVar) import Control.Exception (mask_, onException)-import Control.Monad (join, when)+import Control.Monad (join, unless) import Data.Typeable (Typeable)  -- | 'QSem' is a quantity semaphore in which the resource is aqcuired@@ -57,7 +57,7 @@       flip onException (wake s t) $       atomically $ do         b <- readTVar t-        when (not b) retry+        unless b retry   wake :: QSem -> TVar Bool -> IO ()

Distribution/Client/Config.hs view

@@ -45,7 +45,9 @@   ) where  import Distribution.Client.Types-         ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo )+         ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo+         , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps+         ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Setup@@ -62,7 +64,6 @@          ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags-         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , HaddockFlags(..), haddockOptions, defaultHaddockFlags          , installDirsOptions, optionDistPref          , programDbPaths', programDbOptions@@ -100,7 +101,7 @@ import Distribution.Solver.Types.ConstraintSource  import Data.List-         ( partition, find, foldl' )+         ( partition, find, foldl', nubBy ) import Data.Maybe          ( fromMaybe ) import Control.Monad@@ -135,8 +136,6 @@ import qualified Data.Map as M import Data.Function          ( on )-import Data.List-         ( nubBy ) import GHC.Generics ( Generic )  --@@ -205,6 +204,12 @@         in case b' of [] -> a'                       _  -> b' +      lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a+      lastNonMempty'   field subfield =+        let a' = subfield . field $ a+            b' = subfield . field $ b+        in if b' == mempty then a' else b'+       lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)                       -> NubList a       lastNonEmptyNL' field subfield =@@ -229,7 +234,8 @@         globalIgnoreExpiry      = combine globalIgnoreExpiry,         globalHttpTransport     = combine globalHttpTransport,         globalNix               = combine globalNix,-        globalStoreDir          = combine globalStoreDir+        globalStoreDir          = combine globalStoreDir,+        globalProgPathExtra     = lastNonEmptyNL globalProgPathExtra         }         where           combine        = combine'        savedGlobalFlags@@ -239,6 +245,7 @@         installDocumentation         = combine installDocumentation,         installHaddockIndex          = combine installHaddockIndex,         installDryRun                = combine installDryRun,+        installDest                  = combine installDest,         installMaxBackjumps          = combine installMaxBackjumps,         installReorderGoals          = combine installReorderGoals,         installCountConflicts        = combine installCountConflicts,@@ -287,6 +294,7 @@         configProfLib             = combine configProfLib,         configProf                = combine configProf,         configSharedLib           = combine configSharedLib,+        configStaticLib           = combine configStaticLib,         configDynExe              = combine configDynExe,         configProfExe             = combine configProfExe,         configProfDetail          = combine configProfDetail,@@ -318,6 +326,7 @@         -- TODO: NubListify         configPackageDBs          = lastNonEmpty configPackageDBs,         configGHCiLib             = combine configGHCiLib,+        configSplitSections       = combine configSplitSections,         configSplitObjs           = combine configSplitObjs,         configStripExes           = combine configStripExes,         configStripLibs           = combine configStripLibs,@@ -326,7 +335,7 @@         -- TODO: NubListify         configDependencies        = lastNonEmpty configDependencies,         -- TODO: NubListify-        configConfigurationsFlags = lastNonEmpty configConfigurationsFlags,+        configConfigurationsFlags = lastNonMempty configConfigurationsFlags,         configTests               = combine configTests,         configBenchmarks          = combine configBenchmarks,         configCoverage            = combine configCoverage,@@ -334,15 +343,13 @@         configExactConfiguration  = combine configExactConfiguration,         configFlagError           = combine configFlagError,         configRelocatable         = combine configRelocatable,-        configAllowOlder          = combineMonoid savedConfigureFlags-                                    configAllowOlder,-        configAllowNewer          = combineMonoid savedConfigureFlags-                                    configAllowNewer+        configUseResponseFiles    = combine configUseResponseFiles         }         where           combine        = combine'        savedConfigureFlags           lastNonEmpty   = lastNonEmpty'   savedConfigureFlags           lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags+          lastNonMempty  = lastNonMempty'  savedConfigureFlags        combinedSavedConfigureExFlags = ConfigExFlags {         configCabalVersion  = combine configCabalVersion,@@ -350,7 +357,9 @@         configExConstraints = lastNonEmpty configExConstraints,         -- TODO: NubListify         configPreferences   = lastNonEmpty configPreferences,-        configSolver        = combine configSolver+        configSolver        = combine configSolver,+        configAllowNewer    = combineMonoid savedConfigureExFlags configAllowNewer,+        configAllowOlder    = combineMonoid savedConfigureExFlags configAllowOlder         }         where           combine      = combine' savedConfigureExFlags@@ -398,12 +407,13 @@         haddockForeignLibs   = combine haddockForeignLibs,         haddockInternal      = combine haddockInternal,         haddockCss           = combine haddockCss,-        haddockHscolour      = combine haddockHscolour,+        haddockLinkedSource  = combine haddockLinkedSource,         haddockHscolourCss   = combine haddockHscolourCss,         haddockContents      = combine haddockContents,         haddockDistPref      = combine haddockDistPref,         haddockKeepTempFiles = combine haddockKeepTempFiles,-        haddockVerbosity     = combine haddockVerbosity+        haddockVerbosity     = combine haddockVerbosity,+        haddockCabalFilePath = combine haddockCabalFilePath         }         where           combine      = combine'        savedHaddockFlags@@ -422,6 +432,7 @@ baseSavedConfig :: IO SavedConfig baseSavedConfig = do   userPrefix <- defaultCabalDir+  cacheDir   <- defaultCacheDir   logsDir    <- defaultLogsDir   worldFile  <- defaultWorldFile   return mempty {@@ -434,6 +445,7 @@       prefix             = toFlag (toPathTemplate userPrefix)     },     savedGlobalFlags = mempty {+      globalCacheDir     = toFlag cacheDir,       globalLogsDir      = toFlag logsDir,       globalWorldFile    = toFlag worldFile     }@@ -451,6 +463,7 @@   logsDir    <- defaultLogsDir   worldFile  <- defaultWorldFile   extraPath  <- defaultExtraPath+  symlinkPath <- defaultSymlinkPath   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,@@ -463,7 +476,8 @@     savedInstallFlags    = mempty {       installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")],       installBuildReports= toFlag AnonymousReports,-      installNumJobs     = toFlag Nothing+      installNumJobs     = toFlag Nothing,+      installSymlinkBinDir = toFlag symlinkPath     }   } @@ -498,6 +512,11 @@   dir <- defaultCabalDir   return [dir </> "bin"] +defaultSymlinkPath :: IO FilePath+defaultSymlinkPath = do+  dir <- defaultCabalDir+  return (dir </> "bin")+ defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor @@ -610,7 +629,7 @@     Nothing -> do       notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "."       notice verbosity $ "Config file " ++ configFile ++ " not found."-      createDefaultConfigFile verbosity configFile+      createDefaultConfigFile verbosity [] configFile     Just (ParseOk ws conf) -> do       unless (null ws) $ warn verbosity $         unlines (map (showPWarning configFile) ws)@@ -659,12 +678,13 @@         then return Nothing         else ioError ioe -createDefaultConfigFile :: Verbosity -> FilePath -> IO SavedConfig-createDefaultConfigFile verbosity filePath = do+createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig+createDefaultConfigFile verbosity extraLines filePath  = do   commentConf <- commentSavedConfig   initialConf <- initialSavedConfig+  extraConf   <- parseExtraLines verbosity extraLines   notice verbosity $ "Writing default configuration to " ++ filePath-  writeConfigFile filePath commentConf initialConf+  writeConfigFile filePath commentConf (initialConf `mappend` extraConf)   return initialConf  writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()@@ -705,11 +725,12 @@             globalRemoteRepos = toNubList [defaultRemoteRepo]             },         savedInstallFlags      = defaultInstallFlags,-        savedConfigureExFlags  = defaultConfigExFlags,+        savedConfigureExFlags  = defaultConfigExFlags {+            configAllowNewer     = Just (AllowNewer mempty),+            configAllowOlder     = Just (AllowOlder mempty)+            },         savedConfigureFlags    = (defaultConfigFlags defaultProgramDb) {-            configUserInstall    = toFlag defaultUserInstall,-            configAllowNewer     = Just (AllowNewer RelaxDepsNone),-            configAllowOlder     = Just (AllowOlder RelaxDepsNone)+            configUserInstall    = toFlag defaultUserInstall             },         savedUserInstallDirs   = fmap toFlag userInstallDirs,         savedGlobalInstallDirs = fmap toFlag globalInstallDirs,@@ -752,16 +773,7 @@        [simpleField "compiler"           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)           configHcFlavor (\v flags -> flags { configHcFlavor = v })-       ,let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse-            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in-        simpleField "allow-older"-        (showRelaxDeps . fmap unAllowOlder) parseAllowOlder-        configAllowOlder (\v flags -> flags { configAllowOlder = v })-       ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse-            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in-        simpleField "allow-newer"-        (showRelaxDeps . fmap unAllowNewer) parseAllowNewer-        configAllowNewer (\v flags -> flags { configAllowNewer = v })+         -- TODO: The following is a temporary fix. The "optimization"         -- and "debug-info" fields are OptArg, and viewAsFieldDescr         -- fails on that. Instead of a hand-written hackaged parser@@ -818,7 +830,18 @@    ++ toSavedConfig liftConfigExFlag        (configureExOptions ParseArgs src)-       [] []+       []+       [let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse+            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in+        simpleField "allow-older"+        (showRelaxDeps . fmap unAllowOlder) parseAllowOlder+        configAllowOlder (\v flags -> flags { configAllowOlder = v })+       ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse+            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in+        simpleField "allow-newer"+        (showRelaxDeps . fmap unAllowNewer) parseAllowNewer+        configAllowNewer (\v flags -> flags { configAllowNewer = v })+       ]    ++ toSavedConfig liftInstallFlag        (installOptions ParseArgs)@@ -861,12 +884,12 @@     optional = Parse.option mempty . fmap toFlag  -    showRelaxDeps Nothing              = mempty-    showRelaxDeps (Just RelaxDepsNone) = Disp.text "False"-    showRelaxDeps (Just _)             = Disp.text "True"+    showRelaxDeps Nothing                     = mempty+    showRelaxDeps (Just rd) | isRelaxDeps rd  = Disp.text "True"+                            | otherwise       = Disp.text "False"      toRelaxDeps True  = RelaxDepsAll-    toRelaxDeps False = RelaxDepsNone+    toRelaxDeps False = mempty   -- TODO: next step, make the deprecated fields elicit a warning.@@ -961,7 +984,9 @@    return config {     savedGlobalFlags       = (savedGlobalFlags config) {-       globalRemoteRepos   = toNubList remoteRepoSections+       globalRemoteRepos   = toNubList remoteRepoSections,+       -- the global extra prog path comes from the configure flag prog path+       globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)        },     savedConfigureFlags    = (savedConfigureFlags config) {        configProgramPaths  = paths,@@ -1140,16 +1165,30 @@   map viewAsFieldDescr $   programDbOptions defaultProgramDb ParseArgs id (++) +parseExtraLines :: Verbosity -> [String] -> IO SavedConfig+parseExtraLines verbosity extraLines =+                case parseConfig (ConstraintSourceMainConfig "additional lines")+                     mempty (unlines extraLines) of+                  ParseFailed err ->+                    let (line, msg) = locatedErrorMsg err+                    in die' verbosity $+                         "Error parsing additional config lines\n"+                         ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+                  ParseOk [] r -> return r+                  ParseOk ws _ -> die' verbosity $+                         unlines (map (showPWarning "Error parsing additional config lines") ws)+ -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist.-userConfigDiff :: GlobalFlags -> IO [String]-userConfigDiff globalFlags = do+userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String]+userConfigDiff verbosity globalFlags extraLines = do   userConfig <- loadRawConfig normal (globalConfigFile globalFlags)+  extraConfig <- parseExtraLines verbosity extraLines   testConfig <- initialSavedConfig   return $ reverse . foldl' createDiff [] . M.toList                 $ M.unionWith combine                     (M.fromList . map justFst $ filterShow testConfig)-                    (M.fromList . map justSnd $ filterShow userConfig)+                    (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))   where     justFst (a, b) = (a, (Just b, Nothing))     justSnd (a, b) = (a, (Nothing, Just b))@@ -1170,7 +1209,7 @@      filterShow :: SavedConfig -> [(String, String)]     filterShow cfg = map keyValueSplit-        . filter (\s -> not (null s) && any (== ':') s)+        . filter (\s -> not (null s) && ':' `elem` s)         . map nonComment         . lines         $ showConfig cfg@@ -1187,9 +1226,10 @@   -- | Update the user's ~/.cabal/config' keeping the user's customizations.-userConfigUpdate :: Verbosity -> GlobalFlags -> IO ()-userConfigUpdate verbosity globalFlags = do+userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO ()+userConfigUpdate verbosity globalFlags extraLines = do   userConfig  <- loadRawConfig normal (globalConfigFile globalFlags)+  extraConfig <- parseExtraLines verbosity extraLines   newConfig   <- initialSavedConfig   commentConf <- commentSavedConfig   cabalFile <- getConfigFilePath $ globalConfigFile globalFlags@@ -1197,4 +1237,4 @@   notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."   renameFile cabalFile backup   notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."-  writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig)+  writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig `mappend` extraConfig)

Distribution/Client/Configure.hs view

@@ -38,7 +38,6 @@          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Targets          ( userToPackageConstraint, userConstraintPackageName )-import Distribution.Package (PackageId) import Distribution.Client.JobControl (Lock)  import qualified Distribution.Solver.Types.ComponentDeps as CD@@ -57,33 +56,25 @@ import Distribution.Simple.Program (ProgramDb) import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) import Distribution.Simple.Setup-         ( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..)+         ( ConfigFlags(..)          , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.PackageIndex          ( InstalledPackageIndex, lookupPackageName )-import Distribution.Simple.Utils-         ( defaultPackageDesc ) import Distribution.Package-         ( Package(..), packageName )+         ( Package(..), packageName, PackageId ) import Distribution.Types.Dependency          ( Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PkgDesc-#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse-         ( readGenericPackageDescription )-#endif import Distribution.PackageDescription.Configuration          ( finalizePD ) import Distribution.Version          ( Version, mkVersion, anyVersion, thisVersion          , VersionRange, orLaterVersion ) import Distribution.Simple.Utils as Utils-         ( warn, notice, debug, die' )-import Distribution.Simple.Setup-         ( isRelaxDeps )+         ( warn, notice, debug, die'+         , defaultPackageDesc ) import Distribution.System          ( Platform ) import Distribution.Text ( display )@@ -94,16 +85,16 @@  -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags.-chooseCabalVersion :: ConfigFlags -> Maybe Version -> VersionRange-chooseCabalVersion configFlags maybeVersion =+chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange+chooseCabalVersion configExFlags maybeVersion =   maybe defaultVersionRange thisVersion maybeVersion   where     -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed     -- for '--allow-newer' to work.     allowNewer = isRelaxDeps-                 (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags)+                 (maybe mempty unAllowNewer $ configAllowNewer configExFlags)     allowOlder = isRelaxDeps-                 (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configFlags)+                 (maybe mempty unAllowOlder $ configAllowOlder configExFlags)      defaultVersionRange = if allowOlder || allowNewer                           then orLaterVersion (mkVersion [1,19,2])@@ -173,7 +164,7 @@            (useDistPref defaultSetupScriptOptions)            (configDistPref configFlags))         (chooseCabalVersion-           configFlags+           configExFlags            (flagToMaybe (configCabalVersion configExFlags)))         Nothing         False@@ -213,6 +204,7 @@     , useLoggingHandle         = Nothing     , useWorkingDir            = Nothing     , useExtraPathEnv          = []+    , useExtraEnvOverrides     = []     , setupCacheLock           = lock     , useWin32CleanHack        = False     , forceExternalSetupMethod = forceExternal@@ -323,9 +315,9 @@        resolverParams =           removeLowerBounds-          (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configFlags)+          (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)         . removeUpperBounds-          (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configFlags)+          (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)          . addPreferences             -- preferences from the config file or command line

Distribution/Client/Dependency.hs view

@@ -61,23 +61,27 @@     removeUpperBounds,     addDefaultSetupDependencies,     addSetupCabalMinVersionConstraint,+    addSetupCabalMaxVersionConstraint,   ) where  import Distribution.Solver.Modular-         ( modularResolver, SolverConfig(..) )+         ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types          ( SourcePackageDb(SourcePackageDb)-         , UnresolvedPkgLoc, UnresolvedSourcePackage )+         , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints+         , UnresolvedPkgLoc, UnresolvedSourcePackage+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..)+         , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps+         ) import Distribution.Client.Dependency.Types          ( PreSolver(..), Solver(..)          , PackagesPreferenceDefault(..) ) import Distribution.Client.Sandbox.Types          ( SandboxPackageInfo(..) )-import Distribution.Client.Targets import Distribution.Package          ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId          , Package(..), packageName, packageVersion )@@ -88,26 +92,21 @@          ( finalizePD ) import Distribution.Client.PackageUtils          ( externalBuildDepends )-import Distribution.Version-         ( Version, mkVersion-         , VersionRange, anyVersion, thisVersion, orLaterVersion, withinRange-         , simplifyVersionRange, removeLowerBound, removeUpperBound ) import Distribution.Compiler          ( CompilerInfo(..) ) import Distribution.System          ( Platform ) import Distribution.Client.Utils-         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )+         ( duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils          ( comparing )-import Distribution.Simple.Configure-         ( relaxPackageDeps ) import Distribution.Simple.Setup-         ( asBool, AllowNewer(..), AllowOlder(..), RelaxDeps(..) )+         ( asBool ) import Distribution.Text          ( display ) import Distribution.Verbosity          ( normal, Verbosity )+import Distribution.Version import qualified Distribution.Compat.Graph as Graph  import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)@@ -133,7 +132,7 @@ import Data.List          ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set)@@ -426,24 +425,18 @@ -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. -- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams-removeUpperBounds (AllowNewer RelaxDepsNone) params = params-removeUpperBounds (AllowNewer allowNewer)    params =-    params {-      depResolverSourcePkgIndex = sourcePkgIndex'-    }-  where-    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params--    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage-    relaxDeps srcPkg = srcPkg {-      packageDescription = relaxPackageDeps removeUpperBound allowNewer-                           (packageDescription srcPkg)-      }+removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps  -- | Dual of 'removeUpperBounds' removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams-removeLowerBounds (AllowOlder RelaxDepsNone) params = params-removeLowerBounds (AllowOlder allowNewer)    params =+removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps++data RelaxKind = RelaxLower | RelaxUpper++-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds'+removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams+removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation+removeBounds  relKind relDeps            params =     params {       depResolverSourcePkgIndex = sourcePkgIndex'     }@@ -452,10 +445,65 @@      relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage     relaxDeps srcPkg = srcPkg {-      packageDescription = relaxPackageDeps removeLowerBound allowNewer+      packageDescription = relaxPackageDeps relKind relDeps                            (packageDescription srcPkg)       } +-- | Relax the dependencies of this package if needed.+--+-- Helper function used by 'removeBounds'+relaxPackageDeps :: RelaxKind+                 -> RelaxDeps+                 -> PD.GenericPackageDescription -> PD.GenericPackageDescription+relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'+relaxPackageDeps relKind RelaxDepsAll  gpd = PD.transformAllBuildDepends relaxAll gpd+  where+    relaxAll :: Dependency -> Dependency+    relaxAll (Dependency pkgName verRange) =+        Dependency pkgName (removeBound relKind RelaxDepModNone verRange)++relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =+  PD.transformAllBuildDepends relaxSome gpd+  where+    thisPkgName    = packageName gpd+    thisPkgId      = packageId   gpd+    depsToRelax    = Map.fromList $ mapMaybe f depsToRelax0++    f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod)+    f (RelaxedDep scope rdm p) = case scope of+      RelaxDepScopeAll        -> Just (p,rdm)+      RelaxDepScopePackage p0+          | p0 == thisPkgName -> Just (p,rdm)+          | otherwise         -> Nothing+      RelaxDepScopePackageId p0+          | p0 == thisPkgId   -> Just (p,rdm)+          | otherwise         -> Nothing++    relaxSome :: Dependency -> Dependency+    relaxSome d@(Dependency depName verRange)+        | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =+            -- a '*'-subject acts absorbing, for consistency with+            -- the 'Semigroup RelaxDeps' instance+            Dependency depName (removeBound relKind relMod verRange)+        | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =+            Dependency depName (removeBound relKind relMod verRange)+        | otherwise = d -- no-op++-- | Internal helper for 'relaxPackageDeps'+removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange+removeBound RelaxLower RelaxDepModNone = removeLowerBound+removeBound RelaxUpper RelaxDepModNone = removeUpperBound+removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange+  where+    embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v)+    embed vr                     = embedVersionRange vr++    -- This function is the interesting part as it defines the meaning+    -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints;+    caretTransformation l u = case relKind of+      RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@+      RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@+ -- | Supply defaults for packages without explicit Setup dependencies -- -- Note: It's important to apply 'addDefaultSetupDepends' after@@ -478,16 +526,18 @@               PD.setupBuildInfo =                 case PD.setupBuildInfo pkgdesc of                   Just sbi -> Just sbi-                  Nothing  -> case defaultSetupDeps srcpkg of+                  Nothing -> case defaultSetupDeps srcpkg of                     Nothing -> Nothing-                    Just deps -> Just PD.SetupBuildInfo {-                      PD.defaultSetupDepends = True,-                      PD.setupDepends        = deps-                    }+                    Just deps | isCustom -> Just PD.SetupBuildInfo {+                                                PD.defaultSetupDepends = True,+                                                PD.setupDepends        = deps+                                            }+                              | otherwise -> Nothing             }           }         }       where+        isCustom = PD.buildType pkgdesc == PD.Custom         gpkgdesc = packageDescription srcpkg         pkgdesc  = PD.packageDescription gpkgdesc @@ -506,7 +556,22 @@   where     cabalPkgname = mkPackageName "Cabal" +-- | Variant of 'addSetupCabalMinVersionConstraint' which sets an+-- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'.+--+addSetupCabalMaxVersionConstraint :: Version+                                  -> DepResolverParams -> DepResolverParams+addSetupCabalMaxVersionConstraint maxVersion =+    addConstraints+      [ LabeledPackageConstraint+          (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)+                             (PackagePropertyVersion $ earlierVersion maxVersion))+          ConstraintSetupCabalMaxVersion+      ]+  where+    cabalPkgname = mkPackageName "Cabal" + upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest @@ -572,7 +637,7 @@         where           gpkgdesc = packageDescription srcpkg           pkgdesc  = PD.packageDescription gpkgdesc-          bt       = fromMaybe PD.Custom (PD.buildType pkgdesc)+          bt       = PD.buildType pkgdesc           affected = bt == PD.Custom && hasBuildableFalse gpkgdesc        -- Does this package contain any components with non-empty 'build-depends'@@ -670,7 +735,7 @@   $ runSolver solver (SolverConfig reordGoals cntConflicts                       indGoals noReinstalls                       shadowing strFlags allowBootLibs maxBkjumps enableBj-                      solveExes order verbosity)+                      solveExes order verbosity (PruneAfterFirstSuccess False))                      platform comp installedPkgIndex sourcePkgIndex                      pkgConfigDB preferences constraints targets   where@@ -842,7 +907,8 @@                           -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo   (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') =-     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]+     [ DuplicateFlag flag+     | flag <- PD.findDuplicateFlagAssignments specifiedFlags ]   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]   ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]   ++ [ DuplicateDeps pkgs@@ -859,7 +925,7 @@      mergedFlags = mergeBy compare       (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))-      (sort $ map fst specifiedFlags)+      (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO      packageSatisfiesDependency       (PackageIdentifier name  version)

Distribution/Client/DistDirLayout.hs view

@@ -2,7 +2,7 @@  -- | ----- The layout of the .\/dist\/ directory where cabal keeps all of it's state+-- The layout of the .\/dist\/ directory where cabal keeps all of its state -- and build artifacts. -- module Distribution.Client.DistDirLayout (@@ -185,10 +185,14 @@         display (distParamPlatform params) </>         display (distParamCompilerId params) </>         display (distParamPackageId params) </>-        (case fmap componentNameString (distParamComponentName params) of-            Nothing          -> ""-            Just Nothing     -> ""-            Just (Just name) -> "c" </> display name) </>+        (case distParamComponentName params of+            Nothing                  -> ""+            Just CLibName            -> ""+            Just (CSubLibName name)  -> "l" </> display name+            Just (CFLibName name)    -> "f" </> display name+            Just (CExeName name)     -> "x" </> display name+            Just (CTestName name)    -> "t" </> display name+            Just (CBenchName name)   -> "b" </> display name) </>         (case distParamOptimization params of             NoOptimisation -> "noopt"             NormalOptimisation -> ""

Distribution/Client/Fetch.hs view

@@ -1,5 +1,4 @@--------------------------------------------------------------------------------- |+------------------------------------------------------------------------------- | -- Module      :  Distribution.Client.Fetch -- Copyright   :  (c) David Himmelstrup 2005 --                    Duncan Coutts 2011@@ -25,6 +24,9 @@ import Distribution.Client.Setup          ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) +import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage@@ -37,7 +39,7 @@ import Distribution.Simple.Program          ( ProgramDb ) import Distribution.Simple.Setup-         ( fromFlag )+         ( fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils          ( die', notice, debug ) import Distribution.System@@ -168,6 +170,13 @@        . setSolverVerbosity verbosity +      . addConstraints+          [ let pc = PackageConstraint+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)+                     (PackagePropertyStanzas stanzas)+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+          | pkgSpecifier <- pkgSpecifiers ]+         -- Reinstall the targets given on the command line so that the dep         -- resolver will decide that they need fetching, even if they're         -- already installed. Since we want to get the source packages of@@ -178,6 +187,11 @@      includeDependencies = fromFlag (fetchDeps fetchFlags)     logMsg message rest = debug verbosity message >> rest++    stanzas           = [ TestStanzas | testsEnabled ]+                     ++ [ BenchStanzas | benchmarksEnabled ]+    testsEnabled      = fromFlagOrDefault False $ fetchTests fetchFlags+    benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags      reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)     countConflicts   = fromFlag (fetchCountConflicts   fetchFlags)

Distribution/Client/FetchUtils.hs view

@@ -178,7 +178,7 @@             path = packageFile repo pkgid         createDirectoryIfMissing True dir         Sec.uncheckClientErrors $ do-          info verbosity ("writing " ++ path)+          info verbosity ("Writing " ++ path)           Sec.downloadPackage' rep pkgid path         return path

Distribution/Client/GenBounds.hs view

@@ -15,6 +15,9 @@     genBounds   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Init          ( incVersion ) import Distribution.Client.Freeze@@ -29,13 +32,8 @@          ( buildDepends ) import Distribution.PackageDescription.Configuration          ( finalizePD )-#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse-         ( readGenericPackageDescription )-#endif import Distribution.Types.ComponentRequestedSpec          ( defaultComponentRequestedSpec ) import Distribution.Types.Dependency@@ -118,7 +116,7 @@     gpd <- readGenericPackageDescription verbosity path     -- NB: We don't enable tests or benchmarks, since often they     -- don't really have useful bounds.-    let epd = finalizePD [] defaultComponentRequestedSpec+    let epd = finalizePD mempty defaultComponentRequestedSpec                     (const True) platform cinfo [] gpd     case epd of       Left _ -> putStrLn "finalizePD failed"@@ -143,7 +141,7 @@        let thePkgs = filter isNeeded pkgs         let padTo = maximum $ map (length . unPackageName . packageName) pkgs-       mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs+       traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs       depName :: Dependency -> String      depName (Dependency pn _) = unPackageName pn

Distribution/Client/Get.hs view

@@ -23,7 +23,7 @@ import Distribution.Package          ( PackageId, packageId, packageName ) import Distribution.Simple.Setup-         ( Flag(..), fromFlag, fromFlagOrDefault )+         ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils          ( notice, die', info, rawSystemExitCode, writeFileAtomic ) import Distribution.Verbosity@@ -39,7 +39,7 @@ import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils-        ( getSourcePackagesAtIndexState, IndexState(..) )+        ( getSourcePackagesAtIndexState ) import Distribution.Client.Compat.Process         ( readProcessWithExitCode ) import Distribution.Compat.Exception@@ -82,8 +82,7 @@   unless useFork $     mapM_ (checkTarget verbosity) userTargets -  let idxState = fromFlagOrDefault IndexStateHead $-                       getIndexState getFlags+  let idxState = flagToMaybe $ getIndexState getFlags    sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState

Distribution/Client/GlobalFlags.hs view

@@ -69,7 +69,8 @@     globalIgnoreExpiry      :: Flag Bool,    -- ^ Ignore security expiry dates     globalHttpTransport     :: Flag String,     globalNix               :: Flag Bool,  -- ^ Integrate with Nix-    globalStoreDir          :: Flag FilePath+    globalStoreDir          :: Flag FilePath,+    globalProgPathExtra     :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)   } deriving Generic  defaultGlobalFlags :: GlobalFlags@@ -89,7 +90,8 @@     globalIgnoreExpiry      = Flag False,     globalHttpTransport     = mempty,     globalNix               = Flag False,-    globalStoreDir          = mempty+    globalStoreDir          = mempty,+    globalProgPathExtra     = mempty   }  instance Monoid GlobalFlags where@@ -139,18 +141,20 @@ withRepoContext verbosity globalFlags =     withRepoContext'       verbosity-      (fromNubList (globalRemoteRepos   globalFlags))-      (fromNubList (globalLocalRepos    globalFlags))-      (fromFlag    (globalCacheDir      globalFlags))-      (flagToMaybe (globalHttpTransport globalFlags))-      (flagToMaybe (globalIgnoreExpiry  globalFlags))+      (fromNubList (globalRemoteRepos    globalFlags))+      (fromNubList (globalLocalRepos     globalFlags))+      (fromFlag    (globalCacheDir       globalFlags))+      (flagToMaybe (globalHttpTransport  globalFlags))+      (flagToMaybe (globalIgnoreExpiry   globalFlags))+      (fromNubList (globalProgPathExtra globalFlags))  withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath]                  -> FilePath  -> Maybe String -> Maybe Bool+                 -> [FilePath]                  -> (RepoContext -> IO a)                  -> IO a withRepoContext' verbosity remoteRepos localRepos-                 sharedCacheDir httpTransport ignoreExpiry = \callback -> do+                 sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do     transportRef <- newMVar Nothing     let httpLib = Sec.HTTP.transportAdapter                     verbosity@@ -178,7 +182,7 @@       modifyMVar transportRef $ \mTransport -> do         transport <- case mTransport of           Just tr -> return tr-          Nothing -> configureTransport verbosity httpTransport+          Nothing -> configureTransport verbosity extraPaths httpTransport         return (Just transport, transport)      withSecureRepo :: Map Repo SecureRepo

Distribution/Client/HttpUtils.hs view

@@ -38,8 +38,7 @@ import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils          ( die', info, warn, debug, notice, writeFileAtomic-         , copyFileVerbose,  withTempFile-         , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings )+         , copyFileVerbose,  withTempFile ) import Distribution.Client.Utils          ( withTempFileName ) import Distribution.Client.Types@@ -51,9 +50,9 @@ import qualified System.FilePath.Posix as FilePath.Posix          ( splitDirectories ) import System.FilePath-         ( (<.>) )+         ( (<.>), takeFileName, takeDirectory ) import System.Directory-         ( doesFileExist, renameFile )+         ( doesFileExist, renameFile, canonicalizePath ) import System.IO          ( withFile, IOMode(ReadMode), hGetContents, hClose ) import System.IO.Error@@ -61,16 +60,16 @@ import Distribution.Simple.Program          ( Program, simpleProgram, ConfiguredProgram, programPath          , ProgramInvocation(..), programInvocation+         , ProgramSearchPathEntry(..)          , getProgramInvocationOutput ) import Distribution.Simple.Program.Db          ( ProgramDb, emptyProgramDb, addKnownPrograms          , configureAllKnownPrograms-         , requireProgram, lookupProgram )+         , requireProgram, lookupProgram+         , modifyProgramSearchPath ) import Distribution.Simple.Program.Run-        ( IOEncoding(..), getEffectiveEnvironment )+         ( getProgramInvocationOutputAndErrors ) import Numeric (showHex)-import System.Directory (canonicalizePath)-import System.FilePath (takeFileName, takeDirectory) import System.Random (randomRIO) import System.Exit (ExitCode(..)) @@ -267,18 +266,19 @@       , \_ -> Just plainHttpTransport )     ] -configureTransport :: Verbosity -> Maybe String -> IO HttpTransport+configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport -configureTransport verbosity (Just name) =+configureTransport verbosity extraPath (Just name) =     -- the user secifically selected a transport by name so we'll try and     -- configure that one      case find (\(name',_,_,_) -> name' == name) supportedTransports of       Just (_, mprog, _tls, mkTrans) -> do +        let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb         progdb <- case mprog of           Nothing   -> return emptyProgramDb-          Just prog -> snd <$> requireProgram verbosity prog emptyProgramDb+          Just prog -> snd <$> requireProgram verbosity prog baseProgDb                        --      ^^ if it fails, it'll fail here          let Just transport = mkTrans progdb@@ -289,16 +289,17 @@                     ++ intercalate ", "                          [ name' | (name', _, _, _ ) <- supportedTransports ] -configureTransport verbosity Nothing = do+configureTransport verbosity extraPath Nothing = do     -- the user hasn't selected a transport, so we'll pick the first one we     -- can configure successfully, provided that it supports tls      -- for all the transports except plain-http we need to try and find     -- their external executable+    let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb     progdb <- configureAllKnownPrograms  verbosity $                 addKnownPrograms                   [ prog | (_, Just prog, _, _) <- supportedTransports ]-                  emptyProgramDb+                  baseProgDb      let availableTransports =           [ (name, transport)@@ -422,7 +423,7 @@         -- wget doesn't support range requests.         -- so, we not only ignore range request headers,         -- but we also dispay a warning message when we see them.-        let hasRangeHeader =  any (\hdr -> isRangeHeader hdr) reqHeaders+        let hasRangeHeader =  any isRangeHeader reqHeaders             warningMsg     =  "the 'wget' transport currently doesn't support"                            ++ " range requests, which wastes network bandwidth."                            ++ " To fix this, set 'http-transport' to 'curl' or"@@ -544,16 +545,37 @@     gethttp verbosity uri etag destPath reqHeaders = do       resp <- runPowershellScript verbosity $         webclientScript-          (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))-          [ "$wc.DownloadFile(" ++ escape (show uri)-              ++ "," ++ escape destPath ++ ");"-          , "Write-Host \"200\";"-          , "Write-Host $wc.ResponseHeaders.Item(\"ETag\");"+          (escape (show uri))+          (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")+          :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)))+          [ "$response = $request.GetResponse()"+          , "$responseStream = $response.GetResponseStream()"+          , "$buffer = new-object byte[] 10KB"+          , "$count = $responseStream.Read($buffer, 0, $buffer.length)"+          , "while ($count -gt 0)"+          , "{"+          , "    $targetStream.Write($buffer, 0, $count)"+          , "    $count = $responseStream.Read($buffer, 0, $buffer.length)"+          , "}"+          , "Write-Host ($response.StatusCode -as [int]);"+          , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"           ]+          [ "$targetStream.Flush()"+          , "$targetStream.Close()"+          , "$targetStream.Dispose()"+          , "$responseStream.Dispose()"+          ]       parseResponse resp       where-        parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of-          Just i  -> return (i, Nothing) -- TODO extract real etag+        parseResponse :: String -> IO (HttpCode, Maybe ETag)+        parseResponse x =+          case lines $ trim x of+            (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x+            (code:      _) -> fmap (\c -> (c, Nothing  )) $ parseCode code x+            _              -> statusParseFail verbosity uri x+        parseCode :: String -> String -> IO HttpCode+        parseCode code x = case readMaybe code of+          Just i  -> return i           Nothing -> statusParseFail verbosity uri x         etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] @@ -570,15 +592,19 @@         let contentHeader = Header HdrContentType               ("multipart/form-data; boundary=" ++ boundary)         resp <- runPowershellScript verbosity $ webclientScript+          (escape (show uri))           (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)           (uploadFileAction "POST" uri fullPath)+          uploadFileCleanup         parseUploadResponse verbosity uri resp      puthttpfile verbosity uri path auth headers = do       fullPath <- canonicalizePath path       resp <- runPowershellScript verbosity $ webclientScript+        (escape (show uri))         (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)         (uploadFileAction "PUT" uri fullPath)+        uploadFileCleanup       parseUploadResponse verbosity uri resp      runPowershellScript verbosity script = do@@ -590,6 +616,7 @@             , "-NoProfile", "-NonInteractive"             , "-Command", "-"             ]+      debug verbosity script       getProgramInvocationOutput verbosity (programInvocation prog args)         { progInvokeInput = Just (script ++ "\nExit(0);")         }@@ -600,31 +627,74 @@     extraHeaders = [Header HdrAccept "text/plain", useragentHeader]      setupHeaders headers =-      [ "$wc.Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"+      [ "$request." ++ addHeader name value       | Header name value <- headers       ]+      where+        addHeader header value+          = case header of+              HdrAccept           -> "Accept = "           ++ escape value+              HdrUserAgent        -> "UserAgent = "        ++ escape value+              HdrConnection       -> "Connection = "       ++ escape value+              HdrContentLength    -> "ContentLength = "    ++ escape value+              HdrContentType      -> "ContentType = "      ++ escape value+              HdrDate             -> "Date = "             ++ escape value+              HdrExpect           -> "Expect = "           ++ escape value+              HdrHost             -> "Host = "             ++ escape value+              HdrIfModifiedSince  -> "IfModifiedSince = "  ++ escape value+              HdrReferer          -> "Referer = "          ++ escape value+              HdrTransferEncoding -> "TransferEncoding = " ++ escape value+              HdrRange            -> let (start, _:end) =+                                          if "bytes=" `isPrefixOf` value+                                             then break (== '-') value'+                                             else error $ "Could not decode range: " ++ value+                                         value' = drop 6 value+                                     in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"+              name                -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"      setupAuth auth =-      [ "$wc.Credentials = new-object System.Net.NetworkCredential("+      [ "$request.Credentials = new-object System.Net.NetworkCredential("           ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"       | (uname,passwd) <- maybeToList auth       ] -    uploadFileAction method uri fullPath =-      [ "$fileBytes = [System.IO.File]::ReadAllBytes(" ++ escape fullPath ++ ");"-      , "$bodyBytes = $wc.UploadData(" ++ escape (show uri) ++ ","-        ++ show method ++ ", $fileBytes);"-      , "Write-Host \"200\";"-      , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));"+    uploadFileAction method _uri fullPath =+      [ "$request.Method = " ++ show method+      , "$requestStream = $request.GetRequestStream()"+      , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")"+      , "$bufSize=10000"+      , "$chunk = New-Object byte[] $bufSize"+      , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"+      , "{"+      , "  $requestStream.write($chunk, 0, $bytesRead)"+      , "  $requestStream.Flush()"+      , "}"+      , ""+      , "$responseStream = $request.getresponse()"+      , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"+      , "$code = $response.StatusCode -as [int]"+      , "if ($code -eq 0) {"+      , "  $code = 200;"+      , "}"+      , "Write-Host $code"+      , "Write-Host $responseReader.ReadToEnd()"       ] +    uploadFileCleanup =+      [ "$fileStream.Close()"+      , "$requestStream.Close()"+      , "$responseStream.Close()"+      ]+     parseUploadResponse verbosity uri resp = case lines (trim resp) of       (codeStr : message)         | Just code <- readMaybe codeStr -> return (code, unlines message)       _ -> statusParseFail verbosity uri resp -    webclientScript setup action = unlines-      [ "$wc = new-object system.net.webclient;"+    webclientScript uri setup action cleanup = unlines+      [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""+      , "$uri = New-Object \"System.Uri\" " ++ uri+      , "$request = [System.Net.HttpWebRequest]::Create($uri)"       , unlines setup       , "Try {"       , unlines (map ("  " ++) action)@@ -642,6 +712,8 @@       , "  }"       , "} Catch {"       , "  Write-Host $_.Exception.Message;"+      , "} finally {"+      , unlines (map ("  " ++) cleanup)       , "}"       ] @@ -783,38 +855,3 @@ genBoundary = do     i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer     return $ showHex i ""----------------------------------------------------------------------------------- Compat utils---- TODO: This is only here temporarily so we can release without also requiring--- the latest Cabal lib. The function is also included in Cabal now.--getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation-                                    -> IO (String, String, ExitCode)-getProgramInvocationOutputAndErrors verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = envOverrides,-    progInvokeCwd   = mcwd,-    progInvokeInput = minputStr,-    progInvokeOutputEncoding = encoding-  } = do-    let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False-        decode | utf8      = fromUTF8 . normaliseLineEndings-               | otherwise = id-    menv <- getEffectiveEnvironment envOverrides-    (output, errors, exitCode) <- rawSystemStdInOut verbosity-                                    path args-                                    mcwd menv-                                    input utf8-    return (decode output, decode errors, exitCode)-  where-    input =-      case minputStr of-        Nothing       -> Nothing-        Just inputStr -> Just $-          case encoding of-            IOEncodingText -> (inputStr, False)-            IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8

Distribution/Client/IndexUtils.hs view

@@ -20,6 +20,7 @@ module Distribution.Client.IndexUtils (   getIndexFileAge,   getInstalledPackages,+  indexBaseName,   Configure.getInstalledPackagesMonitorFiles,   getSourcePackages,   getSourcePackagesMonitorFiles,@@ -32,6 +33,8 @@   parsePackageIndex,   updateRepoIndexCache,   updatePackageIndexCacheFile,+  writeIndexTimestamp,+  currentIndexTimestamp,   readCacheStrict, -- only used by soon-to-be-obsolete sandbox code    BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType@@ -63,7 +66,7 @@ import qualified Distribution.Simple.Configure as Configure          ( getInstalledPackages, getInstalledPackagesMonitorFiles ) import Distribution.Version-         ( Version, mkVersion, intersectVersionRanges, versionNumbers )+         ( Version, mkVersion, intersectVersionRanges ) import Distribution.Text          ( display, simpleParse ) import Distribution.Simple.Utils@@ -71,19 +74,9 @@ import Distribution.Client.Setup          ( RepoContext(..) ) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec-         ( parseGenericPackageDescriptionMaybe )+         ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse-#else-import Distribution.ParseUtils-         ( ParseResult(..) )-import Distribution.PackageDescription.Parse-         ( parseGenericPackageDescription )-import Distribution.Simple.Utils-         ( fromUTF8, ignoreBOM )-import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse-#endif  import           Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex@@ -96,7 +89,6 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS-import qualified Data.ByteString as BSW8 import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath@@ -197,7 +189,7 @@ -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb getSourcePackages verbosity repoCtxt =-    getSourcePackagesAtIndexState verbosity repoCtxt IndexStateHead+    getSourcePackagesAtIndexState verbosity repoCtxt Nothing  -- | Variant of 'getSourcePackages' which allows getting the source -- packages at a particular 'IndexState'.@@ -208,7 +200,7 @@ -- TODO: Enhance to allow specifying per-repo 'IndexState's and also -- report back per-repo 'IndexStateInfo's (in order for @new-freeze@ -- to access it)-getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState+getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState                            -> IO SourcePackageDb getSourcePackagesAtIndexState verbosity repoCtxt _   | null (repoContextRepos repoCtxt) = do@@ -221,22 +213,36 @@         packageIndex       = mempty,         packagePreferences = mempty       }-getSourcePackagesAtIndexState verbosity repoCtxt idxState = do-  case idxState of-      IndexStateHead      -> info verbosity "Reading available packages..."-      IndexStateTime time ->-          info verbosity ("Reading available packages (for index-state as of "-                          ++ display time ++ ")...")+getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do+  let describeState IndexStateHead        = "most recent state"+      describeState (IndexStateTime time) = "historical state as of " ++ display time    pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do       let rname = maybe "" remoteRepoName $ maybeRepoRemote r+      info verbosity ("Reading available packages of " ++ rname ++ "...")++      idxState <- case mb_idxState of+        Just idxState -> do+          info verbosity $ "Using " ++ describeState idxState +++            " as explicitly requested (via command line / project configuration)"+          return idxState+        Nothing -> do+          mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r)+          case mb_idxState' of+            Nothing -> do+              info verbosity "Using most recent state (could not read timestamp file)"+              return IndexStateHead+            Just idxState -> do+              info verbosity $ "Using " ++ describeState idxState +++                " specified from most recent cabal update"+              return idxState+       unless (idxState == IndexStateHead) $           case r of             RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")             RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')")             RepoSecure {} -> pure () -       let idxState' = case r of             RepoSecure {} -> idxState             _             -> IndexStateHead@@ -250,10 +256,17 @@             return ()         IndexStateTime ts0 -> do             when (isiMaxTime isi /= ts0) $-                warn verbosity ("Requested index-state " ++ display ts0+                if ts0 > isiMaxTime isi+                    then warn verbosity $+                                   "Requested index-state" ++ display ts0+                                ++ " is newer than '" ++ rname ++ "'!"+                                ++ " Falling back to older state ("+                                ++ display (isiMaxTime isi) ++ ")."+                    else info verbosity $+                                   "Requested index-state " ++ display ts0                                 ++ " does not exist in '"++rname++"'!"                                 ++ " Falling back to older state ("-                                ++ display (isiMaxTime isi) ++ ").")+                                ++ display (isiMaxTime isi) ++ ")."             info verbosity ("index-state("++rname++") = " ++                               display (isiMaxTime isi) ++ " (HEAD = " ++                               display (isiHeadTime isi) ++ ")")@@ -270,12 +283,12 @@     packagePreferences = prefs'   } -readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])+readCacheStrict :: NFData pkg => Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency]) readCacheStrict verbosity index mkPkg = do     updateRepoIndexCache verbosity index     cache <- readIndexCache verbosity index     withFile (indexFile index) ReadMode $ \indexHnd ->-      packageListFromCache verbosity mkPkg indexHnd cache ReadPackageIndexStrict+      evaluate . force =<< packageListFromCache verbosity mkPkg indexHnd cache  -- | Read a repository index from disk, from the local file specified by -- the 'Repo'.@@ -344,7 +357,9 @@ -- getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] getSourcePackagesMonitorFiles repos =-    [ indexBaseName repo <.> "cache" | repo <- repos ]+    concat [ [ indexBaseName repo <.> "cache"+             , indexBaseName repo <.> "timestamp" ]+           | repo <- repos ]  -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like.@@ -448,20 +463,11 @@           Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)             where               pkgid  = PackageIdentifier (mkPackageName pkgname) ver-#ifdef CABAL_PARSEC               parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)               descr = case parsed of                   Just d  -> d                   Nothing -> error $ "Couldn't read cabal file "                                     ++ show fileName-#else-              parsed = parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack-                                               $ content-              descr  = case parsed of-                ParseOk _ d -> d-                _           -> error $ "Couldn't read cabal file "-                                    ++ show fileName-#endif           _ -> Nothing         _ -> Nothing @@ -546,6 +552,10 @@ cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" cacheFile (SandboxIndex index)   = index `replaceExtension` "cache" +timestampFile :: Index -> FilePath+timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp"+timestampFile (SandboxIndex index)   = index `replaceExtension` "timestamp"+ -- | Return 'True' if 'Index' uses 01-index format (aka secure repo) is01Index :: Index -> Bool is01Index (RepoIndex _ repo) = case repo of@@ -626,9 +636,6 @@     toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo     toCache (Dep d) = CachePreference d 0 nullTimestamp -data ReadPackageIndexMode = ReadPackageIndexStrict-                          | ReadPackageIndexLazyIO- readPackageIndexCacheFile :: Package pkg                           => Verbosity                           -> (PackageEntry -> pkg)@@ -639,7 +646,7 @@     cache0    <- readIndexCache verbosity index     indexHnd <- openFile (indexFile index) ReadMode     let (cache,isi) = filterCache idxState cache0-    (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache ReadPackageIndexLazyIO+    (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache     pure (pkgs,deps,isi)  @@ -648,10 +655,9 @@                      -> (PackageEntry -> pkg)                       -> Handle                       -> Cache-                      -> ReadPackageIndexMode                       -> IO (PackageIndex pkg, [Dependency])-packageIndexFromCache verbosity mkPkg hnd cache mode = do-     (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache mode+packageIndexFromCache verbosity mkPkg hnd cache = do+     (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache      pkgIndex <- evaluate $ PackageIndex.fromList pkgs      return (pkgIndex, prefs) @@ -668,9 +674,8 @@                      -> (PackageEntry -> pkg)                      -> Handle                      -> Cache-                     -> ReadPackageIndexMode                      -> IO ([pkg], [Dependency])-packageListFromCache verbosity mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries+packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries   where     accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) @@ -683,9 +688,7 @@         pkgtxt <- getEntryContent blockno         pkg    <- readPackageDescription pkgid pkgtxt         return (pkg, pkgtxt)-      case mode of-        ReadPackageIndexLazyIO -> pure ()-        ReadPackageIndexStrict -> evaluate pkg *> evaluate pkgtxt *> pure ()+       let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno)       accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries @@ -713,17 +716,12 @@           -> return content         _ -> interror "unexpected tar entry type" -    interror :: String -> IO a-    interror msg = die' verbosity $ "internal error when reading package index: " ++ msg-                      ++ "The package index or index cache is probably "-                      ++ "corrupt. Running cabal update might fix it."--    readPackageDescription pkgid content = do-        case parseGenericPackageDescription' content of-            ParseGPDOk gpd     -> return gpd-            ParseError (Just specVer) | specVer >= mkVersion [2,0]-                               -> return (dummyPackageDescription specVer)-            ParseError _       -> interror "failed to parse .cabal file"+    readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription+    readPackageDescription pkgid content =+      case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of+        Right gpd                                           -> return gpd+        Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer)+        Left _                                              -> interror "failed to parse .cabal file"       where         dummyPackageDescription :: Version -> GenericPackageDescription         dummyPackageDescription specVer = GenericPackageDescription@@ -743,73 +741,13 @@          dummySynopsis = "<could not be parsed due to unsupported CABAL spec-version>" --- | Result of 'parseGenericPackageDescription''-data ParseGPDResult = ParseGPDOk GenericPackageDescription-                      -- ^ parsing succeeded (may still have unsupported spec-version)-                    | ParseError !(Maybe Version)-                      -- ^ parsing failed, but we were able to recover-                      --   a new-style spec-version declaration+    interror :: String -> IO a+    interror msg = die' verbosity $ "internal error when reading package index: " ++ msg+                      ++ "The package index or index cache is probably "+                      ++ "corrupt. Running cabal update might fix it." --- | Variant of 'parseGenericPackageDescription' which is able to--- extract new-style spec-version in case of parser errors-parseGenericPackageDescription' :: ByteString -> ParseGPDResult-parseGenericPackageDescription' content =-    case parseGPDMaybe of-      Just gpd -> ParseGPDOk gpd-      Nothing  -> ParseError (scanSpecVersion content)-  where-    parseGPDMaybe =-#ifdef CABAL_PARSEC-      parseGenericPackageDescriptionMaybe (BS.toStrict content)-#else-      case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of-        ParseOk _ d -> Just d-        _           -> Nothing-#endif --- | Quickly scan new-style spec-version------ A new-style spec-version declaration begins the .cabal file and--- follow the following case-insensitive grammar (expressed in--- RFC5234 ABNF):------ newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS------ spec-version               = NUM "." NUM [ "." NUM ]------ NUM    = DIGIT0 / DIGITP 1*DIGIT0--- DIGIT0 = %x30-39--- DIGITP = %x31-39--- WS = %20------ TODO: move into lib:Cabal-scanSpecVersion :: ByteString -> Maybe Version-scanSpecVersion bs = do-    fstline':_ <- pure (BS.Char8.lines bs) -    -- parse <newstyle-spec-version-decl>-    -- normalise: remove all whitespace, convert to lower-case-    let fstline = BSW8.map toLowerW8 $ BSW8.filter (/= 0x20) $ BS.toStrict fstline'-    ["cabal-version",vers] <- pure (BSS.split ':' fstline)--    -- parse <spec-version>-    ---    -- This is currently more tolerant regarding leading 0 digits.-    ---    ver <- simpleParse (BSS.unpack vers)-    guard $ case versionNumbers ver of-              [_,_]   -> True-              [_,_,_] -> True-              _       -> False--    pure ver-  where-    -- | Translate ['A'..'Z'] to ['a'..'z']-    toLowerW8 :: Word8 -> Word8-    toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20-                | otherwise            = w-- ------------------------------------------------------------------------ -- Index cache data structure --@@ -848,6 +786,31 @@ writeIndexCache index cache   | is01Index index = encodeFile (cacheFile index) cache   | otherwise       = writeFile (cacheFile index) (show00IndexCache cache)++-- | Write the 'IndexState' to the filesystem+writeIndexTimestamp :: Index -> IndexState -> IO ()+writeIndexTimestamp index st+  = writeFile (timestampFile index) (display st)++-- | Read out the "current" index timestamp, i.e., what+-- timestamp you would use to revert to this version+currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp+currentIndexTimestamp verbosity repoCtxt r = do+    mb_is <- readIndexTimestamp (RepoIndex repoCtxt r)+    case mb_is of+      Just (IndexStateTime ts) -> return ts+      _ -> do+        (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead+        return (isiHeadTime isi)++-- | Read the 'IndexState' from the filesystem+readIndexTimestamp :: Index -> IO (Maybe IndexState)+readIndexTimestamp index+  = fmap simpleParse (readFile (timestampFile index))+        `catchIO` \e ->+            if isDoesNotExistError e+                then return Nothing+                else ioError e  -- | Optimise sharing of equal values inside 'Cache' --

Distribution/Client/Init.hs view

@@ -60,7 +60,8 @@ import Language.Haskell.Extension ( Language(..) )  import Distribution.Client.Init.Types-  ( InitFlags(..), PackageType(..), Category(..) )+  ( InitFlags(..), BuildType(..), PackageType(..), Category(..)+  , displayPackageType ) import Distribution.Client.Init.Licenses   ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) import Distribution.Client.Init.Heuristics@@ -75,6 +76,8 @@   ( runReadE, readP_to_E ) import Distribution.Simple.Setup   ( Flag(..), flagToMaybe )+import Distribution.Simple.Utils+  ( dropWhileEndLE ) import Distribution.Simple.Configure   ( getInstalledPackages ) import Distribution.Simple.Compiler@@ -207,8 +210,20 @@          ?>> fmap (fmap (either UnknownLicense id))                   (maybePrompt flags                     (promptList "Please choose a license" listedLicenses (Just BSD3) display True))-  return $ flags { license = maybeToFlag lic }++  if isLicenseInvalid lic+    then putStrLn promptInvalidOtherLicenseMsg >> getLicense flags+    else return $ flags { license = maybeToFlag lic }+   where+    isLicenseInvalid (Just (UnknownLicense t)) = any (not . isAlphaNum) t+    isLicenseInvalid _ = False++    promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " +++                                   "If your license name has many words, " +++                                   "the convention is to use camel case (e.g. PublicDomain). " +++                                   "Please choose a different license."+     listedLicenses =       knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing                        , Apache Nothing, OtherLicense]@@ -298,16 +313,16 @@ -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags getLibOrExec flags = do-  isLib <-     return (flagToMaybe $ packageType flags)+  pkgType <-     return (flagToMaybe $ packageType flags)            ?>> maybePrompt flags (either (const Library) id `fmap`                                    promptList "What does the package build"-                                   [Library, Executable]-                                   Nothing display False)+                                   [Library, Executable, LibraryAndExecutable]+                                   Nothing displayPackageType False)            ?>> return (Just Library)-  mainFile <- if isLib /= Just Executable then return Nothing else+  mainFile <- if pkgType == Just Library then return Nothing else                     getMainFile flags -  return $ flags { packageType = maybeToFlag isLib+  return $ flags { packageType = maybeToFlag pkgType                  , mainIs = maybeToFlag mainFile                  } @@ -338,8 +353,17 @@                   (Just Haskell2010) display True)           ?>> return (Just Haskell2010) -  return $ flags { language = maybeToFlag lang }+  if invalidLanguage lang+    then putStrLn invalidOtherLanguageMsg >> getLanguage flags+    else return $ flags { language = maybeToFlag lang } +  where+    invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t+    invalidLanguage _ = False++    invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " +++                              "Please enter a different language."+ -- | Ask whether to generate explanatory comments. getGenComments :: InitFlags -> IO InitFlags getGenComments flags = do@@ -671,14 +695,14 @@     ]  writeChangeLog :: InitFlags -> IO ()-writeChangeLog flags = when (any (== defaultChangeLog) $ maybe [] id (extraSrc flags)) $ do+writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do   message flags ("Generating "++ defaultChangeLog ++"...")   writeFileSafe flags defaultChangeLog changeLog  where   changeLog = unlines     [ "# Revision history for " ++ pname     , ""-    , "## " ++ pver ++ "  -- YYYY-mm-dd"+    , "## " ++ pver ++ " -- YYYY-mm-dd"     , ""     , "* First version. Released on an unsuspecting world."     ]@@ -713,17 +737,16 @@ -- | Create Main.hs, but only if we are init'ing an executable and --   the mainIs flag has been provided. createMainHs :: InitFlags -> IO ()-createMainHs flags@InitFlags{ sourceDirs = Just (srcPath:_)-                            , packageType = Flag Executable-                            , mainIs = Flag mainFile } =-  writeMainHs flags (srcPath </> mainFile)-createMainHs flags@InitFlags{ sourceDirs = _-                            , packageType = Flag Executable-                            , mainIs = Flag mainFile } =-  writeMainHs flags mainFile-createMainHs _ = return ()+createMainHs flags =+  if hasMainHs flags then+    case sourceDirs flags of+      Just (srcPath:_) -> writeMainHs flags (srcPath </> mainFile)+      _ -> writeMainHs flags mainFile+  else return ()+  where+    Flag mainFile = mainIs flags --- | Write a main file if it doesn't already exist.+--- | Write a main file if it doesn't already exist. writeMainHs :: InitFlags -> FilePath -> IO () writeMainHs flags mainPath = do   dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)@@ -733,6 +756,13 @@       message flags $ "Generating " ++ mainPath ++ "..."       writeFileSafe flags mainFullPath mainHs +-- | Check that a main file exists.+hasMainHs :: InitFlags -> Bool+hasMainHs flags = case mainIs flags of+  Flag _ -> (packageType flags == Flag Executable+             || packageType flags == Flag LibraryAndExecutable)+  _ -> False+ -- | Default Main.hs file.  Used when no Main.hs exists. mainHs :: String mainHs = unlines@@ -771,7 +801,7 @@ --   structure onto a low-level AST structure and use the existing --   pretty-printing code to generate the file. generateCabalFile :: String -> InitFlags -> String-generateCabalFile fileName c =+generateCabalFile fileName c = trimTrailingWS $   (++ "\n") .   renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $   (if minimal c /= Flag True@@ -849,30 +879,18 @@                 False         , case packageType c of-           Flag Executable ->-             text "\nexecutable" <+>-             text (maybe "" display . flagToMaybe $ packageName c) $$-             nest 2 (vcat-             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True--             , generateBuildInfo Executable c-             ])-           Flag Library    -> text "\nlibrary" $$ nest 2 (vcat-             [ fieldS "exposed-modules" (listField (exposedModules c))-                      (Just "Modules exported by the library.")-                      True--             , generateBuildInfo Library c-             ])+           Flag Executable -> executableStanza+           Flag Library    -> libraryStanza+           Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza            _               -> empty        ]  where-   generateBuildInfo :: PackageType -> InitFlags -> Doc-   generateBuildInfo pkgtype c' = vcat+   generateBuildInfo :: BuildType -> InitFlags -> Doc+   generateBuildInfo buildType c' = vcat      [ fieldS "other-modules" (listField (otherModules c'))-              (Just $ case pkgtype of-                 Library    -> "Modules included in this library but not exported."-                 Executable -> "Modules included in this executable, other than Main.")+              (Just $ case buildType of+                 LibBuild    -> "Modules included in this library but not exported."+                 ExecBuild -> "Modules included in this executable, other than Main.")               True       , fieldS "other-extensions" (listField (otherExts c'))@@ -942,6 +960,28 @@    breakLine  cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs'    breakLine' [] = []    breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs'++   trimTrailingWS :: String -> String+   trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines++   executableStanza :: Doc+   executableStanza = text "\nexecutable" <+>+             text (maybe "" display . flagToMaybe $ packageName c) $$+             nest 2 (vcat+             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True++             , generateBuildInfo ExecBuild c+             ])++   libraryStanza :: Doc+   libraryStanza = text "\nlibrary" $$ nest 2 (vcat+             [ fieldS "exposed-modules" (listField (exposedModules c))+                      (Just "Modules exported by the library.")+                      True++             , generateBuildInfo LibBuild c+             ])+  -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO ()

Distribution/Client/Init/Types.hs view

@@ -78,12 +78,14 @@   -- ones, which is why we want Maybe [foo] for collecting foo values,   -- not Flag [foo]. -data PackageType = Library | Executable+data BuildType = LibBuild | ExecBuild++data PackageType = Library | Executable | LibraryAndExecutable   deriving (Show, Read, Eq) -instance Text PackageType where-  disp = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] -- TODO: eradicateNoParse+displayPackageType :: PackageType -> String+displayPackageType LibraryAndExecutable = "Library and Executable"+displayPackageType pkgtype              = show pkgtype  instance Monoid InitFlags where   mempty = gmempty

Distribution/Client/Install.hs view

@@ -32,8 +32,6 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Data.List-         ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as S import Control.Exception as Exception@@ -72,7 +70,7 @@ import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils-         ( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages )+         ( getSourcePackagesAtIndexState, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.InstallPlan (InstallPlan)@@ -125,7 +123,6 @@ import Distribution.Simple.Setup          ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags-         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal          ( Flag(..)@@ -150,7 +147,8 @@ import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription          ( PackageDescription, GenericPackageDescription(..), Flag(..)-         , FlagAssignment, showFlagValue )+         , FlagAssignment, mkFlagAssignment, unFlagAssignment+         , showFlagValue, diffFlagAssignment, nullFlagAssignment ) import Distribution.PackageDescription.Configuration          ( finalizePD ) import Distribution.ParseUtils@@ -277,8 +275,7 @@   (packageDBs, repoCtxt, comp, _, progdb,_,_,    globalFlags, _, configExFlags, installFlags, _) mUserTargets = do -    let idxState = fromFlagOrDefault IndexStateHead $-                       installIndexState installFlags+    let idxState = flagToMaybe (installIndexState installFlags)      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackagesAtIndexState verbosity repoCtxt idxState@@ -340,7 +337,7 @@      unless (dryRun || nothingToInstall) $ do       buildOutcomes <- performInstallations verbosity-                         args installedPkgIndex installPlan+                       args installedPkgIndex installPlan       postInstallActions verbosity args userTargets installPlan buildOutcomes   where     installPlan = InstallPlan.configureInstallPlan configFlags installPlan0@@ -421,7 +418,7 @@                      (PackagePropertyFlags flags)             in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | let flags = configConfigurationsFlags configFlags-          , not (null flags)+          , not (nullFlagAssignment flags)           , pkgSpecifier <- pkgSpecifiers ]        . addConstraints@@ -459,11 +456,12 @@     allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)     upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)     onlyDeps         = fromFlag (installOnlyDeps          installFlags)-    allowOlder       = fromMaybe (AllowOlder RelaxDepsNone)-                                 (configAllowOlder configFlags)-    allowNewer       = fromMaybe (AllowNewer RelaxDepsNone)-                                 (configAllowNewer configFlags) +    allowOlder       = fromMaybe (AllowOlder mempty)+                                 (configAllowOlder configExFlags)+    allowNewer       = fromMaybe (AllowNewer mempty)+                                 (configAllowNewer configExFlags)+ -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package targetpkg                  => [PackageSpecifier targetpkg]@@ -640,8 +638,7 @@         nub       . sort       . map mungedId-      . catMaybes-      . map (PackageIndex.lookupUnitId installedPkgIndex)+      . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex)      changed (InBoth    pkgid pkgid') = pkgid /= pkgid'     changed _                        = True@@ -697,7 +694,7 @@             x -> Just $ packageVersion $ last x      toFlagAssignment :: [Flag] -> FlagAssignment-    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))+    toFlagAssignment =  mkFlagAssignment . map (\ f -> (flagName f, flagDefault f))      nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment     nonDefaultFlags cpkg =@@ -705,13 +702,13 @@             toFlagAssignment              (genPackageFlags (SourcePackage.packageDescription $                                confPkgSource cpkg))-      in  confPkgFlags cpkg \\ defaultAssignment+      in  confPkgFlags cpkg `diffFlagAssignment` defaultAssignment      showStanzas :: [OptionalStanza] -> String     showStanzas = concatMap ((" *" ++) . showStanza)      showFlagAssignment :: FlagAssignment -> String-    showFlagAssignment = concatMap ((' ' :) . showFlagValue)+    showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment      change (OnlyInLeft pkgid)        = display pkgid ++ " removed"     change (InBoth     pkgid pkgid') = display pkgid ++ " -> "@@ -756,7 +753,7 @@                        (compilerId comp) pkgids                        (configConfigurationsFlags configFlags) -    when (not (null buildReports)) $+    unless (null buildReports) $       info verbosity $         "Solver failure will be reported for "         ++ intercalate "," (map display pkgids)@@ -824,10 +821,13 @@   ,globalFlags, configFlags, _, installFlags, _)   targets installPlan buildOutcomes = do +  updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo+                              comp platform installPlan buildOutcomes+   unless oneShot $     World.insert verbosity worldFile       --FIXME: does not handle flags-      [ World.WorldPkgInfo dep []+      [ World.WorldPkgInfo dep mempty       | UserTargetNamed dep <- targets ]    let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)@@ -849,9 +849,6 @@    printBuildFailures verbosity buildOutcomes -  updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo-                              comp platform installPlan buildOutcomes-   where     reportingLevel = fromFlag (installBuildReports installFlags)     logsDir        = fromFlag (globalLogsDir globalFlags)@@ -1120,7 +1117,7 @@         platform         progdb         distPref-        (chooseCabalVersion configFlags (libVersion miscOptions))+        (chooseCabalVersion configExFlags (libVersion miscOptions))         (Just lock)         parallelInstall         index@@ -1319,7 +1316,7 @@                     ++ " to " ++ tmpDirPath ++ "..."       extractTarGzFile tmpDirPath relUnpackedPath tarballPath       exists <- doesFileExist descFilePath-      when (not exists) $+      unless exists $         die' verbosity $ "Package .cabal file not found: " ++ show descFilePath       maybeRenameDistDir absUnpackedPath       installPkg (Just absUnpackedPath)

Distribution/Client/InstallPlan.hs view

@@ -97,7 +97,7 @@          ( foldl', intercalate ) import qualified Data.Foldable as Foldable (all) import Data.Maybe-         ( fromMaybe, catMaybes )+         ( fromMaybe, mapMaybe ) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Compat.Binary (Binary(..))@@ -905,10 +905,9 @@ problems graph =       [ PackageMissingDeps pkg-       (catMaybes-        (map+       (mapMaybe          (fmap nodeKey . flip Graph.lookup graph)-         missingDeps))+         missingDeps)      | (pkg, missingDeps) <- Graph.broken graph ]    ++ [ PackageCycle cycleGroup

Distribution/Client/List.hs view

@@ -26,6 +26,7 @@          ( Flag(..), unFlagName ) import Distribution.PackageDescription.Configuration          ( flattenPackageDescription )+import Distribution.Pretty (pretty)  import Distribution.Simple.Compiler         ( Compiler, PackageDBStack )@@ -42,15 +43,16 @@ import Distribution.Text          ( Text(disp), display ) +import qualified Distribution.SPDX as SPDX+ import           Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import           Distribution.Solver.Types.SourcePackage  import Distribution.Client.Types-         ( SourcePackageDb(..)-         , UnresolvedSourcePackage )+         ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Client.Targets-         ( UserTarget, resolveUserTargets, PackageSpecifier(..) )+         ( UserTarget, resolveUserTargets ) import Distribution.Client.Setup          ( GlobalFlags(..), ListFlags(..), InfoFlags(..)          , RepoContext(..) )@@ -281,7 +283,7 @@     synopsis          :: String,     description       :: String,     category          :: String,-    license           :: License,+    license           :: Either SPDX.License License,     author            :: String,     maintainer        :: String,     dependencies      :: [ExtDependency],@@ -317,7 +319,7 @@          versions             -> dispTopVersions 4                                    (preferredVersions pkginfo) versions      , maybeShow (homepage pkginfo) "Homepage:" text-     , text "License: " <+> text (display (license pkginfo))+     , text "License: " <+> either pretty pretty (license pkginfo)      ])      $+$ text ""   where@@ -328,9 +330,9 @@ showPackageDetailedInfo pkginfo =   renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $    char '*' <+> disp (pkgName pkginfo)-            <>  maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo)+            Disp.<> maybe empty (\v -> char '-' Disp.<> disp v) (selectedVersion pkginfo)             <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ')-            <>  parens pkgkind+            Disp.<> parens pkgkind    $+$    (nest 4 $ vcat [      entry "Synopsis"      synopsis     hideIfNull     reflowParagraphs@@ -345,7 +347,7 @@    , entry "Bug reports"   bugReports   orNotSpecified text    , entry "Description"   description  hideIfNull     reflowParagraphs    , entry "Category"      category     hideIfNull     text-   , entry "License"       license      alwaysShow     disp+   , entry "License"       license      alwaysShow     (either pretty pretty)    , entry "Author"        author       hideIfNull     reflowLines    , entry "Maintainer"    maintainer   hideIfNull     reflowLines    , entry "Source repo"   sourceRepo   orNotSpecified text@@ -364,7 +366,7 @@       Just Nothing      -> empty       Just (Just other) -> label <+> text other       where-        label   = text fname <> char ':' <> padding+        label   = text fname Disp.<> char ':' Disp.<> padding         padding = text (replicate (13 - length fname ) ' ')      normal      = Nothing@@ -436,7 +438,7 @@     sourceVersions    = map packageVersion sourcePkgs,     preferredVersions = versionPref, -    license      = combine Source.license       source+    license      = combine Source.licenseRaw    source                            Installed.license    installed,     maintainer   = combine Source.maintainer    source                            Installed.maintainer installed,@@ -458,10 +460,8 @@                            Installed.category    installed,     flags        = maybe [] Source.genPackageFlags sourceGeneric,     hasLib       = isJust installed-                || fromMaybe False-                   (fmap (isJust . Source.condLibrary) sourceGeneric),-    hasExe       = fromMaybe False-                   (fmap (not . null . Source.condExecutables) sourceGeneric),+                || maybe False (isJust . Source.condLibrary) sourceGeneric,+    hasExe       = maybe False (not . null . Source.condExecutables) sourceGeneric,     executables  = map fst (maybe [] Source.condExecutables sourceGeneric),     modules      = combine (map Installed.exposedName . Installed.exposedModules)                            installed

Distribution/Client/Nix.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} @@ -10,12 +9,9 @@        , nixShellIfSandboxed        ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif+import Distribution.Client.Compat.Prelude  import Control.Exception (bracket, catch)-import Control.Monad (filterM, when, unless) import System.Directory        ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist        , doesFileExist, removeDirectoryRecursive, removeFile )@@ -28,7 +24,6 @@  import Distribution.Compat.Environment        ( lookupEnv, setEnv, unsetEnv )-import Distribution.Compat.Semigroup  import Distribution.Verbosity @@ -179,7 +174,7 @@   inNixShell :: IO Bool-inNixShell = maybe False (const True) <$> lookupEnv "CABAL_IN_NIX_SHELL"+inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL"   removeGCRoots :: Verbosity -> FilePath -> IO ()

Distribution/Client/Outdated.hs view

@@ -27,7 +27,8 @@ import Distribution.Solver.Types.PackageIndex import Distribution.Client.Sandbox.PackageEnvironment -import Distribution.Package                          (PackageName, packageVersion)+import Distribution.Package                          (PackageName+                                                     ,packageVersion) import Distribution.PackageDescription               (buildDepends) import Distribution.PackageDescription.Configuration (finalizePD) import Distribution.Simple.Compiler                  (Compiler, compilerInfo)@@ -36,20 +37,16 @@        (die', notice, debug, tryFindPackageDesc) import Distribution.System                           (Platform) import Distribution.Text                             (display)-import Distribution.Types.ComponentRequestedSpec     (ComponentRequestedSpec(..))+import Distribution.Types.ComponentRequestedSpec+       (ComponentRequestedSpec(..)) import Distribution.Types.Dependency        (Dependency(..), depPkgName, simplifyDependency) import Distribution.Verbosity                        (Verbosity, silent) import Distribution.Version        (Version, LowerBound(..), UpperBound(..)        ,asVersionIntervals, majorBoundVersion)-#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec        (readGenericPackageDescription)-#else-import Distribution.PackageDescription.Parse-       (readGenericPackageDescription)-#endif  import qualified Data.Set as S import System.Directory                              (getCurrentDirectory)@@ -64,7 +61,8 @@   let freezeFile    = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags)       newFreezeFile = fromFlagOrDefault False                       (outdatedNewFreezeFile outdatedFlags)-      simpleOutput  = fromFlagOrDefault False (outdatedSimpleOutput outdatedFlags)+      simpleOutput  = fromFlagOrDefault False+                      (outdatedSimpleOutput outdatedFlags)       quiet         = fromFlagOrDefault False (outdatedQuiet outdatedFlags)       exitCode      = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags)       ignorePred    = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags)@@ -119,7 +117,8 @@ depsFromFreezeFile verbosity = do   cwd        <- getCurrentDirectory   userConfig <- loadUserConfig verbosity cwd Nothing-  let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ userConfig+  let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $+                userConfig       deps    = userConstraintsToDependencies ucnstrs   debug verbosity "Reading the list of dependencies from the freeze file"   return deps@@ -128,8 +127,10 @@ depsFromNewFreezeFile :: Verbosity -> IO [Dependency] depsFromNewFreezeFile verbosity = do   projectRoot <- either throwIO return =<<-                 findProjectRoot Nothing {- TODO: Support '--project-file': -} Nothing-  let distDirLayout = defaultDistDirLayout projectRoot {- TODO: Support dist dir override -} Nothing+                 findProjectRoot Nothing+                 {- TODO: Support '--project-file': -} Nothing+  let distDirLayout = defaultDistDirLayout projectRoot+                      {- TODO: Support dist dir override -} Nothing   projectConfig  <- runRebuild (distProjectRootDirectory distDirLayout) $                     readProjectLocalFreezeConfig verbosity distDirLayout   let ucnstrs = map fst . projectConfigConstraints . projectConfigShared@@ -146,7 +147,7 @@   path <- tryFindPackageDesc cwd   gpd  <- readGenericPackageDescription verbosity path   let cinfo = compilerInfo comp-      epd = finalizePD [] (ComponentRequestedSpec True True)+      epd = finalizePD mempty (ComponentRequestedSpec True True)             (const True) platform cinfo [] gpd   case epd of     Left _        -> die' verbosity "finalizePD failed"@@ -183,9 +184,10 @@     isOutdated' :: [Version] -> [Version] -> Maybe Version     isOutdated' [] _  = Nothing     isOutdated' _  [] = Nothing-    isOutdated' this latest = let this'   = maximum this-                                  latest' = maximum latest-                              in if this' < latest' then Just latest' else Nothing+    isOutdated' this latest =+      let this'   = maximum this+          latest' = maximum latest+      in if this' < latest' then Just latest' else Nothing      lookupLatest :: Dependency -> [Version]     lookupLatest dep

Distribution/Client/PackageHash.hs view

@@ -29,13 +29,16 @@     hashFromTUF,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Package          ( PackageId, PackageIdentifier(..), mkComponentId          , PkgconfigName ) import Distribution.System-         ( Platform, OS(Windows), buildOS )+         ( Platform, OS(Windows, OSX), buildOS ) import Distribution.PackageDescription-         ( FlagAssignment, showFlagValue )+         ( FlagAssignment, unFlagAssignment, showFlagValue ) import Distribution.Simple.Compiler          ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)          , ProfDetailLevel(..), showProfDetailLevel )@@ -58,12 +61,7 @@ import qualified Data.Set as Set import           Data.Set (Set) -import Data.Typeable-import Data.Maybe        (catMaybes)-import Data.List         (sortBy, intercalate)-import Data.Map          (Map) import Data.Function     (on)-import Distribution.Compat.Binary (Binary(..)) import Control.Exception (evaluate) import System.IO         (withBinaryFile, IOMode(..)) @@ -82,6 +80,7 @@ hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageId   | buildOS == Windows = hashedInstalledPackageIdShort+  | buildOS == OSX     = hashedInstalledPackageIdVeryShort   | otherwise          = hashedInstalledPackageIdLong  -- | Calculate a 'InstalledPackageId' for a package using our nix-style@@ -135,6 +134,41 @@     truncateStr n s | length s <= n = s                     | otherwise     = take (n-1) s ++ "_" +-- | On macOS we shorten the name very aggressively.  The mach-o linker on+-- macOS has a limited load command size, to which the name of the lirbary+-- as well as its relative path (\@rpath) entry count.  To circumvent this,+-- on macOS the libraries are not stored as+--  @store/<libraryname>/libHS<libraryname>.dylib@+-- where libraryname contains the librarys name, version and abi hash, but in+--  @store/lib/libHS<very short libraryname>.dylib@+-- where the very short library name drops all vowels from the package name,+-- and truncates the hash to 4 bytes.+--+-- We therefore only need one \@rpath entry to @store/lib@ instead of one+-- \@rpath entry for each library. And the reduced library name saves some+-- additional space.+--+-- This however has two major drawbacks:+-- 1) Packages can easier collide due to the shortened hash.+-- 2) The lirbaries are *not* prefix relocateable anymore as they all end up+--    in the same @store/lib@ folder.+--+-- The ultimate solution would have to include generating proxy dynamic+-- libraries on macOS, such that the proxy libraries and the linked libraries+-- stay under the load command limit, and the recursive linker is still able+-- to link all of them.+hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =+  mkComponentId $+    intercalate "-"+      [ filter (not . flip elem "aeiou") (display name)+      , display version+      , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs))+      ]+  where+    PackageIdentifier name version = pkgHashPkgId+    truncateHash (HashValue h) = HashValue (BS.take 4 h)+ -- | All the information that contribues to a package's hash, and thus its -- 'InstalledPackageId'. --@@ -168,6 +202,7 @@        pkgHashCoverage            :: Bool,        pkgHashOptimization        :: OptimisationLevel,        pkgHashSplitObjs           :: Bool,+       pkgHashSplitSections       :: Bool,        pkgHashStripLibs           :: Bool,        pkgHashStripExes           :: Bool,        pkgHashDebugInfo           :: DebugInfoLevel,@@ -233,7 +268,7 @@         -- and then all the config       , entry "compilerid"  display pkgHashCompilerId       , entry "platform"    display pkgHashPlatform-      , opt   "flags" []    showFlagAssignment pkgHashFlagAssignment+      , opt   "flags" mempty showFlagAssignment pkgHashFlagAssignment       , opt   "configure-script" [] unwords pkgHashConfigureScriptArgs       , opt   "vanilla-lib" True  display pkgHashVanillaLib       , opt   "shared-lib"  False display pkgHashSharedLib@@ -246,6 +281,7 @@       , opt   "hpc"          False display pkgHashCoverage       , opt   "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization       , opt   "split-objs"   False display pkgHashSplitObjs+      , opt   "split-sections" False display pkgHashSplitSections       , opt   "stripped-lib" False display pkgHashStripLibs       , opt   "stripped-exe" True  display pkgHashStripExes       , opt   "debug-info"   NormalDebugInfo (show . fromEnum) pkgHashDebugInfo@@ -262,7 +298,7 @@          | value == def = Nothing          | otherwise    = entry key format value -    showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst)+    showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment  ----------------------------------------------- -- The specific choice of hash implementation

Distribution/Client/ParseUtils.hs view

@@ -46,10 +46,10 @@          ( OptionField, viewAsFieldDescr )  import Control.Monad    ( foldM )-import Text.PrettyPrint ( (<>), (<+>), ($+$) )+import Text.PrettyPrint ( (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp-         ( Doc, text, colon, vcat, empty, isEmpty, nest )+         ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )   -------------------------@@ -162,8 +162,8 @@ ppField name mdef cur   | Disp.isEmpty cur = maybe Disp.empty                        (\def -> Disp.text "--" <+> Disp.text name-                                <> Disp.colon <+> def) mdef-  | otherwise        = Disp.text name <> Disp.colon <+> cur+                                Disp.<> Disp.colon <+> def) mdef+  | otherwise        = Disp.text name Disp.<> Disp.colon <+> cur  -- | Pretty print a section. --

Distribution/Client/ProjectBuilding.hs view

@@ -35,6 +35,10 @@     BuildFailureReason(..),   ) where +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+ import           Distribution.Client.PackageHash (renderPackageHashInputs) import           Distribution.Client.RebuildMonad import           Distribution.Client.ProjectConfig@@ -65,6 +69,7 @@ import qualified Distribution.PackageDescription as PD import           Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed+import           Distribution.Simple.BuildPaths (haddockDirName) import qualified Distribution.Simple.InstallDirs as InstallDirs import           Distribution.Types.BuildType import           Distribution.Simple.Program@@ -87,6 +92,7 @@ import           Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as LBS+import           Data.List (isPrefixOf)  import           Control.Monad import           Control.Exception@@ -96,6 +102,12 @@ import           System.IO import           System.Directory +#if !MIN_VERSION_directory(1,2,5)+listDirectory :: FilePath -> IO [FilePath]+listDirectory path =+  (filter f) <$> (getDirectoryContents path)+  where f filename = filename /= "." && filename /= ".."+#endif  ------------------------------------------------------------------------------ -- * Overall building strategy.@@ -356,6 +368,7 @@         elab {             elabBuildTargets  = [],             elabTestTargets   = [],+            elabBenchTargets   = [],             elabReplTarget    = Nothing,             elabBuildHaddocks = False         }@@ -676,7 +689,7 @@           verbosity distDirLayout storeDirLayout           buildSettings registerLock cacheLock           sharedPackageConfig-          rpkg+          plan rpkg           srcdir builddir'       where         builddir' = makeRelative srcdir builddir@@ -692,8 +705,9 @@           buildStatus           srcdir builddir ---TODO: [nice to have] do we need to use a with-style for the temp files for downloading http--- packages, or are we going to cache them persistently?+-- TODO: [nice to have] do we need to use a with-style for the temp+-- files for downloading http packages, or are we going to cache them+-- persistently?  -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the -- packages we have to download and fork off an async action to download them.@@ -824,7 +838,7 @@       -- Sanity check       --       exists <- doesFileExist cabalFile-      when (not exists) $+      unless exists $         die' verbosity $ "Package .cabal file not found in the tarball: " ++ cabalFile        -- Overwrite the .cabal with the one from the index, when appropriate@@ -870,6 +884,7 @@                                -> StoreDirLayout                                -> BuildTimeSettings -> Lock -> Lock                                -> ElaboratedSharedConfig+                               -> ElaboratedInstallPlan                                -> ElaboratedReadyPackage                                -> FilePath -> FilePath                                -> IO BuildResult@@ -888,7 +903,7 @@                                  pkgConfigCompiler      = compiler,                                  pkgConfigCompilerProgs = progdb                                }-                               rpkg@(ReadyPackage pkg)+                               plan rpkg@(ReadyPackage pkg)                                srcdir builddir = do      createDirectoryIfMissingVerbose verbosity True builddir@@ -922,6 +937,13 @@     annotateFailure mlogFile BuildFailed $       setup buildCommand buildFlags +    -- Haddock phase+    whenHaddock $ do+      when isParallelBuild $+        notice verbosity $ "Generating " ++ dispname ++ " documentation..."+      annotateFailureNoLog HaddocksFailed $+        setup haddockCommand haddockFlags+     -- Install phase     annotateFailure mlogFile InstallFailed $ do @@ -935,9 +957,25 @@             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@.+            otherFiles <- filter (not . isPrefixOf entryDir) <$> listFilesRecursive tmpDir             -- 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+            return (entryDir, otherFiles)+            where+              listFilesRecursive :: FilePath -> IO [FilePath]+              listFilesRecursive path = do+                files <- fmap (path </>) <$> (listDirectory path)+                allFiles <- forM files $ \file -> do+                  isDir <- doesDirectoryExist file+                  if isDir+                    then listFilesRecursive file+                    else return [file]+                return (concat allFiles)            registerPkg             | not (elabRequiresRegistration pkg) =@@ -992,6 +1030,10 @@      isParallelBuild = buildSettingNumJobs >= 2 +    whenHaddock action+      | elabBuildHaddocks pkg = action+      | otherwise             = return ()+     configureCommand = Cabal.configureCommand defaultProgramDb     configureFlags v = flip filterConfigureFlags v $                        setupHsConfigureFlags rpkg pkgshared@@ -1001,6 +1043,10 @@     buildCommand     = Cabal.buildCommand defaultProgramDb     buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir +    haddockCommand   = Cabal.haddockCommand+    haddockFlags _   = setupHsHaddockFlags pkg pkgshared+                                           verbosity builddir+     generateInstalledPackageInfo :: IO InstalledPackageInfo     generateInstalledPackageInfo =       withTempInstalledPackageInfoFile@@ -1014,7 +1060,7 @@     copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity                                            builddir destdir -    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir+    scriptOptions = setupHsScriptOptions rpkg plan pkgshared srcdir builddir                                          isParallelBuild cacheLock      setup :: CommandUI flags -> (Version -> flags) -> IO ()@@ -1025,7 +1071,9 @@       withLogging $ \mLogFileHandle ->         setupWrapper           verbosity-          scriptOptions { useLoggingHandle = mLogFileHandle }+          scriptOptions+            { useLoggingHandle     = mLogFileHandle+            , useExtraEnvOverrides = dataDirsEnvironmentForPlan plan }           (Just (elabPkgDescription pkg))           cmd flags args @@ -1061,7 +1109,8 @@ buildInplaceUnpackedPackage verbosity                             distDirLayout@DistDirLayout {                               distTempDirectory,-                              distPackageCacheDirectory+                              distPackageCacheDirectory,+                              distDirectory                             }                             BuildTimeSettings{buildSettingNumJobs}                             registerLock cacheLock@@ -1108,7 +1157,7 @@               ifNullThen m m' = do xs <- m                                    if null xs then m' else return xs           monitors <- case PD.buildType (elabPkgDescription pkg) of-            Just Simple -> listSimple+            Simple -> listSimple             -- If a Custom setup was used, AND the Cabal is recent             -- enough to have sdist --list-sources, use that to             -- determine the files that we need to track.  This can@@ -1158,6 +1207,10 @@           annotateFailureNoLog TestsFailed $             setup testCommand testFlags testArgs +        whenBench $+          annotateFailureNoLog BenchFailed $+            setup benchCommand benchFlags benchArgs+         -- Repl phase         --         whenRepl $@@ -1166,8 +1219,15 @@          -- Haddock phase         whenHaddock $-          annotateFailureNoLog HaddocksFailed $-          setup haddockCommand haddockFlags []+          annotateFailureNoLog HaddocksFailed $ do+            setup haddockCommand haddockFlags []+            let haddockTarget = elabHaddockForHackage pkg+            when (haddockTarget == Cabal.ForHackage) $ do+              let dest = distDirectory </> name <.> "tar.gz"+                  name = haddockDirName haddockTarget (elabPkgDescription pkg)+                  docDir = distBuildDirectory distDirLayout dparams </> "doc" </> "html"+              Tar.createTarGzFile dest docDir name+              notice verbosity $ "Documentation tarball created: " ++ dest          return BuildResult {           buildResultDocs    = docsResult,@@ -1189,14 +1249,19 @@      whenRebuild action       | null (elabBuildTargets pkg)-      -- NB: we have to build the test suite!-      , null (elabTestTargets pkg) = return ()+      -- NB: we have to build the test/bench suite!+      , null (elabTestTargets pkg)+      , null (elabBenchTargets pkg) = return ()       | otherwise                   = action      whenTest action       | null (elabTestTargets pkg) = return ()       | otherwise                  = action +    whenBench action+      | null (elabBenchTargets pkg) = return ()+      | otherwise                   = action+     whenRepl action       | isNothing (elabReplTarget pkg) = return ()       | otherwise                     = action@@ -1229,6 +1294,11 @@                                          verbosity builddir     testArgs         = setupHsTestArgs  pkg +    benchCommand     = Cabal.benchmarkCommand+    benchFlags    _  = setupHsBenchFlags pkg pkgshared+                                          verbosity builddir+    benchArgs        = setupHsBenchArgs  pkg+     replCommand      = Cabal.replCommand defaultProgramDb     replFlags _      = setupHsReplFlags pkg pkgshared                                         verbosity builddir@@ -1238,7 +1308,7 @@     haddockFlags _   = setupHsHaddockFlags pkg pkgshared                                            verbosity builddir -    scriptOptions    = setupHsScriptOptions rpkg pkgshared+    scriptOptions    = setupHsScriptOptions rpkg plan pkgshared                                             srcdir builddir                                             isParallelBuild cacheLock

Distribution/Client/ProjectBuilding/Types.hs view

@@ -201,6 +201,7 @@                         | ReplFailed      SomeException                         | HaddocksFailed  SomeException                         | TestsFailed     SomeException+                        | BenchFailed     SomeException                         | InstallFailed   SomeException   deriving Show

Distribution/Client/ProjectConfig.hs view

@@ -20,6 +20,7 @@      -- * Project config files     readProjectConfig,+    readGlobalConfig,     readProjectLocalFreezeConfig,     writeProjectLocalExtraConfig,     writeProjectLocalFreezeConfig,@@ -65,12 +66,12 @@ import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Config-         ( loadConfig, defaultConfigFile )-import Distribution.Client.IndexUtils.Timestamp-         ( IndexState(..) )+         ( loadConfig, getConfigFilePath )  import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.PackageConstraint+         ( PackageProperty(..) )  import Distribution.Package          ( PackageName, PackageId, packageId, UnitId )@@ -79,20 +80,15 @@          ( Platform ) import Distribution.PackageDescription          ( SourceRepo(..) )-#if CABAL_PARSEC import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse-         ( readGenericPackageDescription )-#endif import Distribution.Simple.Compiler          ( Compiler, compilerInfo ) import Distribution.Simple.Program          ( ConfiguredProgram(..) ) import Distribution.Simple.Setup          ( Flag(Flag), toFlag, flagToMaybe, flagToList-         , fromFlag, fromFlagOrDefault, AllowNewer(..), AllowOlder(..), RelaxDeps(..) )+         , fromFlag, fromFlagOrDefault ) import Distribution.Client.Setup          ( defaultSolver, defaultMaxBackjumps ) import Distribution.Simple.InstallDirs@@ -113,7 +109,6 @@ import Control.Monad import Control.Monad.Trans (liftIO) import Control.Exception-import Data.Maybe import Data.Either import qualified Data.Map as Map import Data.Set (Set)@@ -157,6 +152,7 @@       buildSettingCacheDir       buildSettingHttpTransport       (Just buildSettingIgnoreExpiry)+      buildSettingProgPathExtra   -- | Use a 'RepoContext', but only for the solver. The solver does not use the@@ -179,6 +175,7 @@                          projectConfigCacheDir)       (flagToMaybe projectConfigHttpTransport)       (flagToMaybe projectConfigIgnoreExpiry)+      (fromNubList projectConfigProgPathExtra)   -- | Resolve the project configuration, with all its optional fields, into@@ -203,8 +200,8 @@                                           (getMapMappend projectConfigSpecificPackage)     solverSettingCabalVersion      = flagToMaybe projectConfigCabalVersion     solverSettingSolver            = fromFlag projectConfigSolver-    solverSettingAllowOlder        = fromJust projectConfigAllowOlder-    solverSettingAllowNewer        = fromJust projectConfigAllowNewer+    solverSettingAllowOlder        = fromMaybe mempty projectConfigAllowOlder+    solverSettingAllowNewer        = fromMaybe mempty projectConfigAllowNewer     solverSettingMaxBackjumps      = case fromFlag projectConfigMaxBackjumps of                                        n | n < 0     -> Nothing                                          | otherwise -> Just n@@ -212,8 +209,8 @@     solverSettingCountConflicts    = fromFlag projectConfigCountConflicts     solverSettingStrongFlags       = fromFlag projectConfigStrongFlags     solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls-    solverSettingIndexState        = fromFlagOrDefault IndexStateHead projectConfigIndexState-  --solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals+    solverSettingIndexState        = flagToMaybe projectConfigIndexState+    solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals   --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs   --solverSettingReinstall         = fromFlag projectConfigReinstall   --solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls@@ -224,14 +221,14 @@      defaults = mempty {        projectConfigSolver            = Flag defaultSolver,-       projectConfigAllowOlder        = Just (AllowOlder RelaxDepsNone),-       projectConfigAllowNewer        = Just (AllowNewer RelaxDepsNone),+       projectConfigAllowOlder        = Just (AllowOlder mempty),+       projectConfigAllowNewer        = Just (AllowNewer mempty),        projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,        projectConfigReorderGoals      = Flag (ReorderGoals False),        projectConfigCountConflicts    = Flag (CountConflicts True),        projectConfigStrongFlags       = Flag (StrongFlags False),-       projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False)-     --projectConfigIndependentGoals  = Flag (IndependentGoals False),+       projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False),+       projectConfigIndependentGoals  = Flag (IndependentGoals False)      --projectConfigShadowPkgs        = Flag False,      --projectConfigReinstall         = Flag False,      --projectConfigAvoidReinstalls   = Flag False,@@ -254,7 +251,8 @@                          ProjectConfig {                            projectConfigShared = ProjectConfigShared {                              projectConfigRemoteRepos,-                             projectConfigLocalRepos+                             projectConfigLocalRepos,+                             projectConfigProgPathExtra                            },                            projectConfigBuildOnly                          } =@@ -279,6 +277,7 @@     buildSettingIgnoreExpiry  = fromFlag    projectConfigIgnoreExpiry     buildSettingReportPlanningFailure                               = fromFlag projectConfigReportPlanningFailure+    buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra      ProjectConfigBuildOnly{..} = defaults                               <> projectConfigBuildOnly@@ -416,9 +415,9 @@ -- | Read all the config relevant for a project. This includes the project -- file if any, plus other global config. ---readProjectConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig-readProjectConfig verbosity distDirLayout = do-    global <- readGlobalConfig             verbosity+readProjectConfig :: Verbosity -> Flag FilePath -> DistDirLayout -> Rebuild ProjectConfig+readProjectConfig verbosity configFileFlag distDirLayout = do+    global <- readGlobalConfig             verbosity configFileFlag     local  <- readProjectLocalConfig       verbosity distDirLayout     freeze <- readProjectLocalFreezeConfig verbosity distDirLayout     extra  <- readProjectLocalExtraConfig  verbosity distDirLayout@@ -549,16 +548,13 @@  -- | Read the user's @~/.cabal/config@ file. ---readGlobalConfig :: Verbosity -> Rebuild ProjectConfig-readGlobalConfig verbosity = do-    config     <- liftIO (loadConfig verbosity mempty)-    configFile <- liftIO defaultConfigFile+readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig+readGlobalConfig verbosity configFileFlag = do+    config     <- liftIO (loadConfig verbosity configFileFlag)+    configFile <- liftIO (getConfigFilePath configFileFlag)     monitorFiles [monitorFileHashed configFile]     return (convertLegacyGlobalConfig config)-    --TODO: do this properly, there's several possible locations-    -- and env vars, and flags for selecting the global config - reportParseResult :: Verbosity -> String -> FilePath -> ParseResult a -> IO a reportParseResult verbosity _filetype filename (ParseOk warnings x) = do     unless (null warnings) $@@ -764,29 +760,30 @@       :: String -> Rebuild (Maybe (Either BadPackageLocation                                          [ProjectPackageLocation]))     checkIsUriPackage pkglocstr =-      return $!       case parseAbsoluteURI pkglocstr of         Just uri@URI {             uriScheme    = scheme,-            uriAuthority = Just URIAuth { uriRegName = host }+            uriAuthority = Just URIAuth { uriRegName = host },+            uriPath      = path,+            uriQuery     = query,+            uriFragment  = frag           }           | recognisedScheme && not (null host) ->-            Just (Right [ProjectPackageRemoteTarball uri])+            return (Just (Right [ProjectPackageRemoteTarball uri])) -          --TODO: [required eventually] handle file: urls which do have a null-          -- host. translate URI into filepath and use ProjectPackageLocalTarball-          -- or keep as file url and use ProjectPackageRemoteTarball?+          | scheme == "file:" && null host && null query && null frag ->+            checkIsSingleFilePackage path            | not recognisedScheme && not (null host) ->-            Just (Left (BadLocUnexpectedUriScheme pkglocstr))+            return (Just (Left (BadLocUnexpectedUriScheme pkglocstr)))            | recognisedScheme && null host ->-            Just (Left (BadLocUnrecognisedUri pkglocstr))+            return (Just (Left (BadLocUnrecognisedUri pkglocstr)))           where             recognisedScheme = scheme == "http:" || scheme == "https:"                             || scheme == "file:" -        _ -> Nothing+        _ -> return Nothing       checkIsFileGlobPackage pkglocstr =@@ -894,7 +891,7 @@ -- paths. -- readSourcePackage :: Verbosity -> ProjectPackageLocation-                  -> Rebuild UnresolvedSourcePackage+                  -> Rebuild (PackageSpecifier UnresolvedSourcePackage) readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) =     readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile)   where@@ -904,15 +901,27 @@     monitorFiles [monitorFileHashed cabalFile]     root <- askRoot     pkgdesc <- liftIO $ readGenericPackageDescription verbosity (root </> cabalFile)-    return SourcePackage {+    return $ SpecificSourcePackage SourcePackage {       packageInfoId        = packageId pkgdesc,       packageDescription   = pkgdesc,       packageSource        = LocalUnpackedPackage (root </> dir),       packageDescrOverride = Nothing     }++readSourcePackage _ (ProjectPackageNamed (Dependency pkgname verrange)) =+    return $ NamedPackage pkgname [PackagePropertyVersion verrange]+ readSourcePackage _verbosity _ =     fail $ "TODO: add support for fetching and reading local tarballs, remote "         ++ "tarballs, remote repos and passing named packages through"+++-- TODO: add something like this, here or in the project planning+-- Based on the package location, which packages will be built inplace in the+-- build tree vs placed in the store. This has various implications on what we+-- can do with the package, e.g. can we run tests, ghci etc.+--+-- packageIsLocalToProject :: ProjectPackageLocation -> Bool   ---------------------------------------------

Distribution/Client/ProjectConfig/Legacy.hs view

@@ -25,7 +25,9 @@  import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types-         ( RemoteRepo(..), emptyRemoteRepo )+         ( RemoteRepo(..), emptyRemoteRepo+         , AllowNewer(..), AllowOlder(..) )+ import Distribution.Client.Config          ( SavedConfig(..), remoteRepoFields ) @@ -33,18 +35,19 @@  import Distribution.Package import Distribution.PackageDescription-         ( SourceRepo(..), RepoKind(..) +         ( SourceRepo(..), RepoKind(..)          , dispFlagAssignment, parseFlagAssignment )-import Distribution.PackageDescription.Parse+import Distribution.Client.SourceRepoParse          ( sourceRepoFieldDescrs ) import Distribution.Simple.Compiler          ( OptimisationLevel(..), DebugInfoLevel(..) )+import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) import Distribution.Simple.Setup          ( Flag(Flag), toFlag, fromFlagOrDefault          , ConfigFlags(..), configureOptions          , HaddockFlags(..), haddockOptions, defaultHaddockFlags          , programDbPaths', splitArgs-         , AllowNewer(..), AllowOlder(..), RelaxDeps(..) )+         ) import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags@@ -79,7 +82,6 @@          , OptionField, option, reqArg' )  import qualified Data.Map as Map- ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types --@@ -100,6 +102,7 @@        legacyPackagesNamed     :: [Dependency],         legacySharedConfig      :: LegacySharedConfig,+       legacyAllConfig         :: LegacyPackageConfig,        legacyLocalConfig       :: LegacyPackageConfig,        legacySpecificConfig    :: MapMappend PackageName LegacyPackageConfig      } deriving Generic@@ -163,10 +166,34 @@       projectConfigShared        = convertLegacyAllPackageFlags                                      globalFlags configFlags                                      configExFlags installFlags,-      projectConfigLocalPackages = convertLegacyPerPackageFlags-                                     configFlags installFlags haddockFlags+      projectConfigLocalPackages = localConfig,+      projectConfigAllPackages   = allConfig     }-+  where (localConfig, allConfig) = splitConfig+                                 (convertLegacyPerPackageFlags+                                    configFlags installFlags haddockFlags)+        -- split the package config (from command line arguments) into+        -- those applied to all packages and those to local only.+        --+        -- for now we will just copy over the ProgramPaths/Args/Extra into+        -- the AllPackages.  The LocalPackages do not inherit them from+        -- AllPackages, and as such need to retain them.+        --+        -- The general decision rule for what to put into allConfig+        -- into localConfig is the following:+        --+        -- - anything that is host/toolchain/env specific should be applied+        --   to all packages, as packagesets have to be host/toolchain/env+        --   consistent.+        -- - anything else should be in the local config and could potentially+        --   be lifted into all-packages vial the `package *` cabal.project+        --   section.+        --+        splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)+        splitConfig pc = (pc+                         , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc+                                  , packageConfigProgramArgs  = packageConfigProgramArgs  pc+                                  , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc })  -- | Convert from the types currently used for the user-wide @~/.cabal/config@ -- file into the 'ProjectConfig' type.@@ -190,9 +217,9 @@       savedHaddockFlags      = haddockFlags     } =     mempty {-      projectConfigShared        = configAllPackages,-      projectConfigLocalPackages = configLocalPackages,-      projectConfigBuildOnly     = configBuildOnly+      projectConfigBuildOnly   = configBuildOnly,+      projectConfigShared      = configShared,+      projectConfigAllPackages = configAllPackages     }   where     --TODO: [code cleanup] eliminate use of default*Flags here and specify the@@ -201,9 +228,9 @@     installFlags'  = defaultInstallFlags  <> installFlags     haddockFlags'  = defaultHaddockFlags  <> haddockFlags -    configLocalPackages = convertLegacyPerPackageFlags+    configAllPackages   = convertLegacyPerPackageFlags                             configFlags installFlags' haddockFlags'-    configAllPackages   = convertLegacyAllPackageFlags+    configShared        = convertLegacyAllPackageFlags                             globalFlags configFlags                             configExFlags' installFlags'     configBuildOnly     = convertLegacyBuildOnlyFlags@@ -224,6 +251,7 @@     legacyPackagesNamed,     legacySharedConfig = LegacySharedConfig globalFlags configShFlags                                             configExFlags installSharedFlags,+    legacyAllConfig,     legacyLocalConfig  = LegacyPackageConfig configFlags installPerPkgFlags                                              haddockFlags,     legacySpecificConfig@@ -236,15 +264,18 @@       projectPackagesNamed         = legacyPackagesNamed,        projectConfigBuildOnly       = configBuildOnly,-      projectConfigShared          = configAllPackages,+      projectConfigShared          = configPackagesShared,       projectConfigProvenance      = mempty,+      projectConfigAllPackages     = configAllPackages,       projectConfigLocalPackages   = configLocalPackages,       projectConfigSpecificPackage = fmap perPackage legacySpecificConfig     }   where+    configAllPackages   = convertLegacyPerPackageFlags g i h+                            where LegacyPackageConfig g i h = legacyAllConfig     configLocalPackages = convertLegacyPerPackageFlags                             configFlags installPerPkgFlags haddockFlags-    configAllPackages   = convertLegacyAllPackageFlags+    configPackagesShared= convertLegacyAllPackageFlags                             globalFlags (configFlags <> configShFlags)                             configExFlags installSharedFlags     configBuildOnly     = convertLegacyBuildOnlyFlags@@ -268,29 +299,31 @@     ProjectConfigShared{..}   where     GlobalFlags {-      globalConfigFile        = _, -- TODO: [required feature]+      globalConfigFile        = projectConfigConfigFile,       globalSandboxConfigFile = _, -- ??       globalRemoteRepos       = projectConfigRemoteRepos,-      globalLocalRepos        = projectConfigLocalRepos+      globalLocalRepos        = projectConfigLocalRepos,+      globalProgPathExtra     = projectConfigProgPathExtra     } = globalFlags      ConfigFlags {       configDistPref            = projectConfigDistDir,       configHcFlavor            = projectConfigHcFlavor,       configHcPath              = projectConfigHcPath,-      configHcPkg               = projectConfigHcPkg,+      configHcPkg               = projectConfigHcPkg+    --configProgramPathExtra    = projectConfigProgPathExtra DELETE ME     --configInstallDirs         = projectConfigInstallDirs,     --configUserInstall         = projectConfigUserInstall,     --configPackageDBs          = projectConfigPackageDBs,-      configAllowOlder          = projectConfigAllowOlder,-      configAllowNewer          = projectConfigAllowNewer     } = configFlags      ConfigExFlags {       configCabalVersion        = projectConfigCabalVersion,       configExConstraints       = projectConfigConstraints,       configPreferences         = projectConfigPreferences,-      configSolver              = projectConfigSolver+      configSolver              = projectConfigSolver,+      configAllowOlder          = projectConfigAllowOlder,+      configAllowNewer          = projectConfigAllowNewer     } = configExFlags      InstallFlags {@@ -305,7 +338,7 @@       installReorderGoals       = projectConfigReorderGoals,       installCountConflicts     = projectConfigCountConflicts,       installPerComponent       = projectConfigPerComponent,-    --installIndependentGoals   = projectConfigIndependentGoals,+      installIndependentGoals   = projectConfigIndependentGoals,     --installShadowPkgs         = projectConfigShadowPkgs,       installStrongFlags        = projectConfigStrongFlags,       installAllowBootLibInstalls = projectConfigAllowBootLibInstalls@@ -328,6 +361,7 @@       configVanillaLib          = packageConfigVanillaLib,       configProfLib             = packageConfigProfLib,       configSharedLib           = packageConfigSharedLib,+      configStaticLib           = packageConfigStaticLib,       configDynExe              = packageConfigDynExe,       configProfExe             = packageConfigProfExe,       configProf                = packageConfigProf,@@ -338,6 +372,7 @@       configProgPrefix          = packageConfigProgPrefix,       configProgSuffix          = packageConfigProgSuffix,       configGHCiLib             = packageConfigGHCiLib,+      configSplitSections       = packageConfigSplitSections,       configSplitObjs           = packageConfigSplitObjs,       configStripExes           = packageConfigStripExes,       configStripLibs           = packageConfigStripLibs,@@ -368,12 +403,13 @@       haddockHtml               = packageConfigHaddockHtml,       haddockHtmlLocation       = packageConfigHaddockHtmlLocation,       haddockForeignLibs        = packageConfigHaddockForeignLibs,+      haddockForHackage         = packageConfigHaddockForHackage,       haddockExecutables        = packageConfigHaddockExecutables,       haddockTestSuites         = packageConfigHaddockTestSuites,       haddockBenchmarks         = packageConfigHaddockBenchmarks,       haddockInternal           = packageConfigHaddockInternal,       haddockCss                = packageConfigHaddockCss,-      haddockHscolour           = packageConfigHaddockHscolour,+      haddockLinkedSource       = packageConfigHaddockLinkedSource,       haddockHscolourCss        = packageConfigHaddockHscolourCss,       haddockContents           = packageConfigHaddockContents     } = haddockFlags@@ -431,6 +467,7 @@       projectPackagesOptional,       projectPackagesRepo,       projectPackagesNamed,+      projectConfigAllPackages,       projectConfigLocalPackages,       projectConfigSpecificPackage     } =@@ -440,6 +477,8 @@       legacyPackagesRepo     = projectPackagesRepo,       legacyPackagesNamed    = projectPackagesNamed,       legacySharedConfig     = convertToLegacySharedConfig projectConfig,+      legacyAllConfig        = convertToLegacyPerPackageConfig+                                 projectConfigAllPackages,       legacyLocalConfig      = convertToLegacyAllPackageConfig projectConfig                             <> convertToLegacyPerPackageConfig                                  projectConfigLocalPackages,@@ -451,7 +490,10 @@ convertToLegacySharedConfig     ProjectConfig {       projectConfigBuildOnly     = ProjectConfigBuildOnly {..},-      projectConfigShared        = ProjectConfigShared {..}+      projectConfigShared        = ProjectConfigShared {..},+      projectConfigAllPackages   = PackageConfig {+        packageConfigDocumentation+      }     } =      LegacySharedConfig {@@ -464,7 +506,7 @@     globalFlags = GlobalFlags {       globalVersion           = mempty,       globalNumericVersion    = mempty,-      globalConfigFile        = mempty,+      globalConfigFile        = projectConfigConfigFile,       globalSandboxConfigFile = mempty,       globalConstraintsFile   = mempty,       globalRemoteRepos       = projectConfigRemoteRepos,@@ -477,26 +519,29 @@       globalIgnoreExpiry      = projectConfigIgnoreExpiry,       globalHttpTransport     = projectConfigHttpTransport,       globalNix               = mempty,-      globalStoreDir          = projectConfigStoreDir+      globalStoreDir          = projectConfigStoreDir,+      globalProgPathExtra     = projectConfigProgPathExtra     }      configFlags = mempty {       configVerbosity     = projectConfigVerbosity,-      configDistPref      = projectConfigDistDir,-      configAllowOlder    = projectConfigAllowOlder,-      configAllowNewer    = projectConfigAllowNewer+      configDistPref      = projectConfigDistDir     }      configExFlags = ConfigExFlags {       configCabalVersion  = projectConfigCabalVersion,       configExConstraints = projectConfigConstraints,       configPreferences   = projectConfigPreferences,-      configSolver        = projectConfigSolver+      configSolver        = projectConfigSolver,+      configAllowOlder    = projectConfigAllowOlder,+      configAllowNewer    = projectConfigAllowNewer+     }      installFlags = InstallFlags {-      installDocumentation     = mempty,+      installDocumentation     = packageConfigDocumentation,       installHaddockIndex      = projectConfigHaddockIndex,+      installDest              = Flag NoCopyDest,       installDryRun            = projectConfigDryRun,       installReinstall         = mempty, --projectConfigReinstall,       installAvoidReinstalls   = mempty, --projectConfigAvoidReinstalls,@@ -505,7 +550,7 @@       installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,       installReorderGoals      = projectConfigReorderGoals,       installCountConflicts    = projectConfigCountConflicts,-      installIndependentGoals  = mempty, --projectConfigIndependentGoals,+      installIndependentGoals  = projectConfigIndependentGoals,       installShadowPkgs        = mempty, --projectConfigShadowPkgs,       installStrongFlags       = projectConfigStrongFlags,       installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,@@ -554,6 +599,7 @@       configVanillaLib          = mempty,       configProfLib             = mempty,       configSharedLib           = mempty,+      configStaticLib           = mempty,       configDynExe              = mempty,       configProfExe             = mempty,       configProf                = mempty,@@ -571,6 +617,7 @@       configUserInstall         = mempty, --projectConfigUserInstall,       configPackageDBs          = mempty, --projectConfigPackageDBs,       configGHCiLib             = mempty,+      configSplitSections       = mempty,       configSplitObjs           = mempty,       configStripExes           = mempty,       configStripLibs           = mempty,@@ -591,8 +638,7 @@       configFlagError           = mempty,                --TODO: ???       configRelocatable         = mempty,       configDebugInfo           = mempty,-      configAllowOlder          = mempty,-      configAllowNewer          = mempty+      configUseResponseFiles    = mempty     }      haddockFlags = mempty {@@ -621,6 +667,7 @@       configVanillaLib          = packageConfigVanillaLib,       configProfLib             = packageConfigProfLib,       configSharedLib           = packageConfigSharedLib,+      configStaticLib           = packageConfigStaticLib,       configDynExe              = packageConfigDynExe,       configProfExe             = packageConfigProfExe,       configProf                = packageConfigProf,@@ -638,6 +685,7 @@       configUserInstall         = mempty,       configPackageDBs          = mempty,       configGHCiLib             = packageConfigGHCiLib,+      configSplitSections       = packageConfigSplitSections,       configSplitObjs           = packageConfigSplitObjs,       configStripExes           = packageConfigStripExes,       configStripLibs           = packageConfigStripLibs,@@ -658,8 +706,7 @@       configFlagError           = mempty,                --TODO: ???       configRelocatable         = packageConfigRelocatable,       configDebugInfo           = packageConfigDebugInfo,-      configAllowOlder          = mempty,-      configAllowNewer          = mempty+      configUseResponseFiles    = mempty     }      installFlags = mempty {@@ -673,19 +720,20 @@       haddockHoogle        = packageConfigHaddockHoogle,       haddockHtml          = packageConfigHaddockHtml,       haddockHtmlLocation  = packageConfigHaddockHtmlLocation,-      haddockForHackage    = mempty, --TODO: added recently+      haddockForHackage    = packageConfigHaddockForHackage,       haddockForeignLibs   = packageConfigHaddockForeignLibs,       haddockExecutables   = packageConfigHaddockExecutables,       haddockTestSuites    = packageConfigHaddockTestSuites,       haddockBenchmarks    = packageConfigHaddockBenchmarks,       haddockInternal      = packageConfigHaddockInternal,       haddockCss           = packageConfigHaddockCss,-      haddockHscolour      = packageConfigHaddockHscolour,+      haddockLinkedSource  = packageConfigHaddockLinkedSource,       haddockHscolourCss   = packageConfigHaddockHscolourCss,       haddockContents      = packageConfigHaddockContents,       haddockDistPref      = mempty,       haddockKeepTempFiles = mempty,-      haddockVerbosity     = mempty+      haddockVerbosity     = mempty,+      haddockCabalFilePath = mempty     }  @@ -798,7 +846,11 @@       [ newLineListField "local-repo"           showTokenQ parseTokenQ           (fromNubList . globalLocalRepos)-          (\v conf -> conf { globalLocalRepos = toNubList v })+          (\v conf -> conf { globalLocalRepos = toNubList v }),+         newLineListField "extra-prog-path-shared-only"+          showTokenQ parseTokenQ+          (fromNubList . globalProgPathExtra)+          (\v conf -> conf { globalProgPathExtra = toNubList v })       ]   . filterFields       [ "remote-repo-cache"@@ -810,18 +862,6 @@   ( liftFields       legacyConfigureShFlags       (\flags conf -> conf { legacyConfigureShFlags = flags })-  . addFields-      [ monoidField "allow-older"-        (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)-        (fmap unAllowOlder . configAllowOlder)-        (\v conf -> conf { configAllowOlder = fmap AllowOlder v })-      ]-  . addFields-      [ monoidField "allow-newer"-        (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)-        (fmap unAllowNewer . configAllowNewer)-        (\v conf -> conf { configAllowNewer = fmap AllowNewer v })-      ]   . filterFields ["verbose", "builddir" ]   . commandOptionsToFields   ) (configureOptions ParseArgs)@@ -837,6 +877,16 @@       , commaNewLineListField "preferences"         disp parse         configPreferences (\v conf -> conf { configPreferences = v })++      , monoidField "allow-older"+        (maybe mempty disp) (fmap Just parse)+        (fmap unAllowOlder . configAllowOlder)+        (\v conf -> conf { configAllowOlder = fmap AllowOlder v })++      , monoidField "allow-newer"+        (maybe mempty disp) (fmap Just parse)+        (fmap unAllowNewer . configAllowNewer)+        (\v conf -> conf { configAllowNewer = fmap AllowNewer v })       ]   . filterFields       [ "cabal-lib-version", "solver"@@ -861,27 +911,15 @@       , "remote-build-reporting", "report-planning-failure"       , "one-shot", "jobs", "keep-going", "offline", "per-component"         -- solver flags:-      , "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags"-      , "allow-boot-library-installs", "index-state"+      , "max-backjumps", "reorder-goals", "count-conflicts", "independent-goals"+      , "strong-flags" , "allow-boot-library-installs", "index-state"       ]   . commandOptionsToFields   ) (installOptions ParseArgs)   where     constraintSrc = ConstraintSourceProjectConfig "TODO" -parseRelaxDeps :: ReadP r RelaxDeps-parseRelaxDeps =-     ((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None"))-  +++ (const RelaxDepsAll  <$> (Parse.string "all"  +++ Parse.string "All")))-  <++ (      RelaxDepsSome <$> parseOptCommaList parse) -dispRelaxDeps :: RelaxDeps -> Doc-dispRelaxDeps  RelaxDepsNone       = Disp.text "None"-dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma-                                               . map disp $ pkgs-dispRelaxDeps  RelaxDepsAll        = Disp.text "All"-- legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] legacyPackageConfigFieldDescrs =   ( liftFields@@ -917,10 +955,10 @@       [ "with-compiler", "with-hc-pkg"       , "program-prefix", "program-suffix"       , "library-vanilla", "library-profiling"-      , "shared", "executable-dynamic"+      , "shared", "static", "executable-dynamic"       , "profiling", "executable-profiling"       , "profiling-detail", "library-profiling-detail"-      , "library-for-ghci", "split-objs"+      , "library-for-ghci", "split-objs", "split-sections"       , "executable-stripping", "library-stripping"       , "tests", "benchmarks"       , "coverage", "library-coverage"@@ -954,6 +992,12 @@       (\flags conf -> conf { legacyHaddockFlags = flags })   . mapFieldNames       ("haddock-"++)+  . addFields+      [ simpleField "for-hackage"+          -- TODO: turn this into a library function+          (fromFlagOrDefault Disp.empty . fmap disp) (Parse.option mempty (fmap toFlag parse))+          haddockForHackage (\v conf -> conf { haddockForHackage = v })+      ]   . filterFields       [ "hoogle", "html", "html-location"       , "foreign-libraries"@@ -1074,45 +1118,61 @@                            }     } +-- | The definitions of all the fields that can appear in the @package pkgfoo@+-- and @package *@ sections of the @cabal.project@-format files.+--+packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig]+packageSpecificOptionsFieldDescrs =+    legacyPackageConfigFieldDescrs+ ++ programOptionsFieldDescrs+      (configProgramArgs . legacyConfigureFlags)+      (\args pkgconf -> pkgconf {+          legacyConfigureFlags = (legacyConfigureFlags pkgconf) {+            configProgramArgs  = args+          }+        }+      )+ ++ liftFields+      legacyConfigureFlags+      (\flags pkgconf -> pkgconf {+          legacyConfigureFlags = flags+        }+      )+      programLocationsFieldDescrs++-- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format+-- files. This section is per-package name. The special package @*@ applies to all+-- packages used anywhere by the project, locally or as dependencies.+-- packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig packageSpecificOptionsSectionDescr =     SectionDescr {       sectionName        = "package",-      sectionFields      = legacyPackageConfigFieldDescrs-                        ++ programOptionsFieldDescrs-                             (configProgramArgs . legacyConfigureFlags)-                             (\args pkgconf -> pkgconf {-                                 legacyConfigureFlags = (legacyConfigureFlags pkgconf) {-                                   configProgramArgs  = args-                                 }-                               }-                             )-                        ++ liftFields-                             legacyConfigureFlags-                             (\flags pkgconf -> pkgconf {-                                 legacyConfigureFlags = flags-                               }-                             )-                             programLocationsFieldDescrs,+      sectionFields      = packageSpecificOptionsFieldDescrs,       sectionSubsections = [],       sectionGet         = \projconf ->                              [ (display pkgname, pkgconf)                              | (pkgname, pkgconf) <-                                  Map.toList . getMapMappend-                               . legacySpecificConfig $ projconf ],+                               . legacySpecificConfig $ projconf ]+                          ++ [ ("*", legacyAllConfig projconf) ],       sectionSet         =-        \lineno pkgnamestr pkgconf projconf -> do-          pkgname <- case simpleParse pkgnamestr of-            Just pkgname -> return pkgname-            Nothing      -> syntaxError lineno $-                                "a 'package' section requires a package name "-                             ++ "as an argument"-          return projconf {-            legacySpecificConfig =-              MapMappend $-              Map.insertWith mappend pkgname pkgconf-                             (getMapMappend $ legacySpecificConfig projconf)-          },+        \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of+          "*" -> return projconf {+                   legacyAllConfig = legacyAllConfig projconf <> pkgconf+                 }+          _   -> do+            pkgname <- case simpleParse pkgnamestr of+              Just pkgname -> return pkgname+              Nothing      -> syntaxError lineno $+                                  "a 'package' section requires a package name "+                               ++ "as an argument"+            return projconf {+              legacySpecificConfig =+                MapMappend $+                Map.insertWith mappend pkgname pkgconf+                               (getMapMappend $ legacySpecificConfig projconf)+            },       sectionEmpty       = mempty     }

Distribution/Client/ProjectConfig/Types.hs view

@@ -21,7 +21,7 @@   ) where  import Distribution.Client.Types-         ( RemoteRepo )+         ( RemoteRepo, AllowNewer(..), AllowOlder(..) ) import Distribution.Client.Dependency.Types          ( PreSolver ) import Distribution.Client.Targets@@ -48,7 +48,7 @@          ( Compiler, CompilerFlavor          , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup-         ( Flag, AllowNewer(..), AllowOlder(..) )+         ( Flag, HaddockTarget(..) ) import Distribution.Simple.InstallDirs          ( PathTemplate ) import Distribution.Utils.NubList@@ -113,6 +113,10 @@        projectConfigShared          :: ProjectConfigShared,        projectConfigProvenance      :: Set ProjectConfigProvenance, +       -- | Configuration to be applied to *all* packages,+       -- whether named in `cabal.project` or not.+       projectConfigAllPackages     :: PackageConfig,+        -- | Configuration to be applied to *local* packages; i.e.,        -- any packages which are explicitly named in `cabal.project`.        projectConfigLocalPackages   :: PackageConfig,@@ -155,6 +159,7 @@ data ProjectConfigShared    = ProjectConfigShared {        projectConfigDistDir           :: Flag FilePath,+       projectConfigConfigFile        :: Flag FilePath,        projectConfigProjectFile       :: Flag FilePath,        projectConfigHcFlavor          :: Flag CompilerFlavor,        projectConfigHcPath            :: Flag FilePath,@@ -186,11 +191,13 @@        projectConfigCountConflicts    :: Flag CountConflicts,        projectConfigStrongFlags       :: Flag StrongFlags,        projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls,-       projectConfigPerComponent      :: Flag Bool+       projectConfigPerComponent      :: Flag Bool,+       projectConfigIndependentGoals  :: Flag IndependentGoals, +       projectConfigProgPathExtra     :: NubList FilePath+        -- More things that only make sense for manual mode, not --local mode        -- too much control!-     --projectConfigIndependentGoals  :: Flag IndependentGoals,      --projectConfigShadowPkgs        :: Flag Bool,      --projectConfigReinstall         :: Flag Bool,      --projectConfigAvoidReinstalls   :: Flag Bool,@@ -227,6 +234,7 @@        packageConfigFlagAssignment      :: FlagAssignment,        packageConfigVanillaLib          :: Flag Bool,        packageConfigSharedLib           :: Flag Bool,+       packageConfigStaticLib           :: Flag Bool,        packageConfigDynExe              :: Flag Bool,        packageConfigProf                :: Flag Bool, --TODO: [code cleanup] sort out        packageConfigProfLib             :: Flag Bool, --      this duplication@@ -241,6 +249,7 @@        packageConfigExtraFrameworkDirs  :: [FilePath],        packageConfigExtraIncludeDirs    :: [FilePath],        packageConfigGHCiLib             :: Flag Bool,+       packageConfigSplitSections       :: Flag Bool,        packageConfigSplitObjs           :: Flag Bool,        packageConfigStripExes           :: Flag Bool,        packageConfigStripLibs           :: Flag Bool,@@ -260,9 +269,10 @@        packageConfigHaddockBenchmarks   :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockInternal     :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockCss          :: Flag FilePath, --TODO: [required eventually] use this-       packageConfigHaddockHscolour     :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this        packageConfigHaddockHscolourCss  :: Flag FilePath, --TODO: [required eventually] use this-       packageConfigHaddockContents     :: Flag PathTemplate --TODO: [required eventually] use this+       packageConfigHaddockContents     :: Flag PathTemplate, --TODO: [required eventually] use this+       packageConfigHaddockForHackage   :: Flag HaddockTarget      }   deriving (Eq, Show, Generic) @@ -283,7 +293,7 @@   mappend = (<>)  instance Ord k => Semigroup (MapLast k v) where-  MapLast a <> MapLast b = MapLast (flip Map.union a b)+  MapLast a <> MapLast b = MapLast $ Map.union b a   -- rather than Map.union which is the normal Map monoid instance  @@ -361,10 +371,10 @@        solverSettingCountConflicts    :: CountConflicts,        solverSettingStrongFlags       :: StrongFlags,        solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,-       solverSettingIndexState        :: IndexState+       solverSettingIndexState        :: Maybe IndexState,+       solverSettingIndependentGoals  :: IndependentGoals        -- Things that only make sense for manual mode, not --local mode        -- too much control!-     --solverSettingIndependentGoals  :: IndependentGoals,      --solverSettingShadowPkgs        :: Bool,      --solverSettingReinstall         :: Bool,      --solverSettingAvoidReinstalls   :: Bool,@@ -406,6 +416,6 @@        buildSettingLocalRepos            :: [FilePath],        buildSettingCacheDir              :: FilePath,        buildSettingHttpTransport         :: Maybe String,-       buildSettingIgnoreExpiry          :: Bool+       buildSettingIgnoreExpiry          :: Bool,+       buildSettingProgPathExtra         :: [FilePath]      }-

Distribution/Client/ProjectOrchestration.hs view

@@ -4,7 +4,7 @@  -- | This module deals with building and incrementally rebuilding a collection -- of packages. It is what backs the @cabal build@ and @configure@ commands,--- as well as being a core part of @run@, @test@, @bench@ and others. +-- as well as being a core part of @run@, @test@, @bench@ and others. -- -- The primary thing is in fact rebuilding (and trying to make that quick by -- not redoing unnecessary work), so building from scratch is just a special@@ -33,7 +33,7 @@ -- This division helps us keep the code under control, making it easier to -- understand, test and debug. So when you are extending these modules, please -- think about which parts of your change belong in which part. It is--- perfectly ok to extend the description of what to do (i.e. the +-- perfectly ok to extend the description of what to do (i.e. the -- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the -- first phase. Also, the second phase does not have direct access to any of -- the input configuration anyway; all the information has to flow via the@@ -94,6 +94,9 @@     cmdCommonHelpTextNewBuildBeta,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import           Distribution.Client.ProjectConfig import           Distribution.Client.ProjectPlanning                    hiding ( pruneInstallPlanToTargets )@@ -104,7 +107,8 @@ import           Distribution.Client.ProjectPlanOutput  import           Distribution.Client.Types-                   ( GenericReadyPackage(..), UnresolvedSourcePackage )+                   ( GenericReadyPackage(..), UnresolvedSourcePackage+                   , PackageSpecifier(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import           Distribution.Client.TargetSelector                    ( TargetSelector(..)@@ -113,29 +117,36 @@ import           Distribution.Client.DistDirLayout import           Distribution.Client.Config (defaultCabalDir) import           Distribution.Client.Setup hiding (packageName)+import           Distribution.Types.ComponentName+                   ( componentNameString )+import           Distribution.Types.UnqualComponentName+                   ( UnqualComponentName, packageNameToUnqualComponentName )  import           Distribution.Solver.Types.OptionalStanza  import           Distribution.Package                    hiding (InstalledPackageId, installedPackageId)-import           Distribution.PackageDescription (FlagAssignment, showFlagValue)+import           Distribution.PackageDescription+                   ( FlagAssignment, unFlagAssignment, showFlagValue+                   , diffFlagAssignment ) import           Distribution.Simple.LocalBuildInfo                    ( ComponentName(..), pkgComponents ) import qualified Distribution.Simple.Setup as Setup import           Distribution.Simple.Command (commandShowOptions)+import           Distribution.Simple.Configure (computeEffectiveProfiling)  import           Distribution.Simple.Utils                    ( die'                    , notice, noticeNoWrap, debugNoWrap ) import           Distribution.Verbosity import           Distribution.Text+import           Distribution.Simple.Compiler+                   ( showCompilerId+                   , OptimisationLevel(..))  import qualified Data.Monoid as Mon import qualified Data.Set as Set import qualified Data.Map as Map-import           Data.Map (Map)-import           Data.List-import           Data.Maybe import           Data.Either import           Control.Exception (Exception(..), throwIO, assert) import           System.Exit (ExitCode(..), exitFailure)@@ -151,7 +162,7 @@        distDirLayout  :: DistDirLayout,        cabalDirLayout :: CabalDirLayout,        projectConfig  :: ProjectConfig,-       localPackages  :: [UnresolvedSourcePackage],+       localPackages  :: [PackageSpecifier UnresolvedSourcePackage],        buildSettings  :: BuildTimeSettings      } @@ -222,7 +233,11 @@        -- | The result of the dry-run phase. This tells us about each member of       -- the 'elaboratedPlanToExecute'.-      pkgsBuildStatus        :: BuildStatusMap+      pkgsBuildStatus        :: BuildStatusMap,++      -- | The targets selected by @selectPlanSubset@. This is useful eg. in+      -- CmdRun, where we need a valid target to execute.+      targetsMap             :: TargetsMap     }  @@ -231,7 +246,7 @@ runProjectPreBuildPhase     :: Verbosity     -> ProjectBaseContext-    -> (ElaboratedInstallPlan -> IO ElaboratedInstallPlan)+    -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))     -> IO ProjectBuildContext runProjectPreBuildPhase     verbosity@@ -258,7 +273,7 @@     -- Now given the specific targets the user has asked for, decide     -- which bits of the plan we will want to execute.     ---    elaboratedPlan' <- selectPlanSubset elaboratedPlan+    (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan      -- Check which packages need rebuilding.     -- This also gives us more accurate reasons for the --dry-run output.@@ -276,7 +291,8 @@       elaboratedPlanOriginal = elaboratedPlan,       elaboratedPlanToExecute = elaboratedPlan'',       elaboratedShared,-      pkgsBuildStatus+      pkgsBuildStatus,+      targetsMap = targets     }  @@ -341,10 +357,11 @@                          pkgsBuildStatus                          buildOutcomes -    writePlanGhcEnvironment distDirLayout-                            elaboratedPlanOriginal-                            elaboratedShared-                            postBuildStatus+    void $ writePlanGhcEnvironment (distProjectRootDirectory+                                      distDirLayout)+                                   elaboratedPlanOriginal+                                   elaboratedShared+                                   postBuildStatus      -- Finally if there were any build failures then report them and throw     -- an exception to terminate the program@@ -364,7 +381,7 @@     -- on it) all go into the install plan.      -- Notionally, the 'BuildFlags' should be things that do not affect what-    -- we build, just how we do it. These ones of course do +    -- we build, just how we do it. These ones of course do   ------------------------------------------------------------------------------@@ -380,7 +397,7 @@ -- possible to for different selectors to match the same target. This extra -- information is primarily to help make helpful error messages. ---type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector PackageId])]+type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])]  -- | Given a set of 'TargetSelector's, resolve which 'UnitId's and -- 'ComponentTarget's they ought to refer to.@@ -415,18 +432,18 @@ -- a basis for their own @selectComponentTarget@ implementation. -- resolveTargets :: forall err.-                  (forall k. TargetSelector PackageId+                  (forall k. TargetSelector                           -> [AvailableTarget k]                           -> Either err [k])-               -> (forall k. PackageId -> ComponentName -> SubComponentTarget+               -> (forall k. SubComponentTarget                           -> AvailableTarget k                           -> Either err  k )                -> (TargetProblemCommon -> err)                -> ElaboratedInstallPlan-               -> [TargetSelector PackageId]+               -> [TargetSelector]                -> Either [err] TargetsMap resolveTargets selectPackageTargets selectComponentTarget liftProblem-               installPlan targetSelectors =+               installPlan =     --TODO: [required eventually]     -- we cannot resolve names of packages other than those that are     -- directly in the current plan. We ought to keep a set of the known@@ -434,72 +451,171 @@     -- really need that until we can do something sensible with packages     -- outside of the project. -    case partitionEithers-           [ fmap ((,) targetSelector) (checkTarget targetSelector)-           | targetSelector <- targetSelectors ] of-      ([], targets) -> Right-                     . Map.map nubComponentTargets-                     $ Map.fromListWith (++)-                         [ (uid, [(ct, ts)])-                         | (ts, cts) <- targets-                         , (uid, ct) <- cts ]--      (problems, _) -> Left problems+      fmap mkTargetsMap+    . checkErrors+    . map (\ts -> (,) ts <$> checkTarget ts)   where-    -- TODO [required eventually] currently all build targets refer to packages-    -- inside the project. Ultimately this has to be generalised to allow-    -- referring to other packages and targets.-    checkTarget :: TargetSelector PackageId-                -> Either err [(UnitId, ComponentTarget)]+    mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])]+                 -> TargetsMap+    mkTargetsMap targets =+        Map.map nubComponentTargets+      $ Map.fromListWith (++)+          [ (uid, [(ct, ts)])+          | (ts, cts) <- targets+          , (uid, ct) <- cts ] +    AvailableTargetIndexes{..} = availableTargetIndexes installPlan++    checkTarget :: TargetSelector -> Either err [(UnitId, ComponentTarget)]+     -- We can ask to build any whole package, project-local or a dependency-    checkTarget bt@(TargetPackage _ pkgid mkfilter)+    checkTarget bt@(TargetPackage _ [pkgid] mkfilter)       | Just ats <- fmap (maybe id filterTargetsKind mkfilter)-                  $ Map.lookup pkgid availableTargetsByPackage-      = case selectPackageTargets bt ats of-          Left  e  -> Left e-          Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent)-                            | (unitid, cname) <- ts ]+                  $ Map.lookup pkgid availableTargetsByPackageId+      = fmap (componentTargets WholeComponent)+      $ selectPackageTargets bt ats        | otherwise       = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) +    checkTarget (TargetPackage _ _ _)+      = error "TODO: add support for multiple packages in a directory"+      -- For the moment this error cannot happen here, because it gets+      -- detected when the package config is being constructed. This case+      -- will need handling properly when we do add support.+      --+      -- TODO: how should this use case play together with the+      -- '--cabal-file' option of 'configure' which allows using multiple+      -- .cabal files for a single package?+     checkTarget bt@(TargetAllPackages mkfilter) =-      let ats = maybe id filterTargetsKind mkfilter-              $ filter availableTargetLocalToProject-              $ concat (Map.elems availableTargetsByPackage)-       in case selectPackageTargets bt ats of-            Left  e  -> Left e-            Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent)-                              | (unitid, cname) <- ts ]+        fmap (componentTargets WholeComponent)+      . selectPackageTargets bt+      . maybe id filterTargetsKind mkfilter+      . filter availableTargetLocalToProject+      $ concat (Map.elems availableTargetsByPackageId)      checkTarget (TargetComponent pkgid cname subtarget)-      | Just ats <- Map.lookup (pkgid, cname) availableTargetsByComponent-      = case partitionEithers-               (map (selectComponentTarget pkgid cname subtarget) ats) of-          (e:_,_) -> Left e-          ([],ts) -> Right [ (unitid, ctarget)-                           | let ctarget = ComponentTarget cname subtarget-                           , (unitid, _) <- ts ]+      | Just ats <- Map.lookup (pkgid, cname)+                               availableTargetsByPackageIdAndComponentName+      = fmap (componentTargets subtarget)+      $ selectComponentTargets subtarget ats -      | Map.member pkgid availableTargetsByPackage+      | Map.member pkgid availableTargetsByPackageId       = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname))        | otherwise       = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) -    --TODO: check if the package is in the plan, even if it's not local+    checkTarget (TargetComponentUnknown pkgname ecname subtarget)+      | Just ats <- case ecname of+          Left ucname ->+            Map.lookup (pkgname, ucname)+                       availableTargetsByPackageNameAndUnqualComponentName+          Right cname ->+            Map.lookup (pkgname, cname)+                       availableTargetsByPackageNameAndComponentName+      = fmap (componentTargets subtarget)+      $ selectComponentTargets subtarget ats++      | Map.member pkgname availableTargetsByPackageName+      = Left (liftProblem (TargetProblemUnknownComponent pkgname ecname))++      | otherwise+      = Left (liftProblem (TargetNotInProject pkgname))++    checkTarget bt@(TargetPackageNamed pkgname mkfilter)+      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)+                  $ Map.lookup pkgname availableTargetsByPackageName+      = fmap (componentTargets WholeComponent)+      . selectPackageTargets bt+      $ ats++      | otherwise+      = Left (liftProblem (TargetNotInProject pkgname))     --TODO: check if the package is in hackage and return different     -- error cases here so the commands can handle things appropriately -    availableTargetsByPackage   :: Map PackageId                  [AvailableTarget (UnitId, ComponentName)]-    availableTargetsByComponent :: Map (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)]-    availableTargetsByComponent = availableTargets installPlan-    availableTargetsByPackage   = Map.mapKeysWith-                                    (++) (\(pkgid, _cname) -> pkgid)-                                    availableTargetsByComponent-                      `Map.union` availableTargetsEmptyPackages+    componentTargets :: SubComponentTarget+                     -> [(b, ComponentName)]+                     -> [(b, ComponentTarget)]+    componentTargets subtarget =+      map (fmap (\cname -> ComponentTarget cname subtarget)) +    selectComponentTargets :: SubComponentTarget+                           -> [AvailableTarget k]+                           -> Either err [k]+    selectComponentTargets subtarget =+        either (Left . head) Right+      . checkErrors+      . map (selectComponentTarget subtarget)++    checkErrors :: [Either e a] -> Either [e] [a]+    checkErrors = (\(es, xs) -> if null es then Right xs else Left es)+                . partitionEithers+++data AvailableTargetIndexes = AvailableTargetIndexes {+       availableTargetsByPackageIdAndComponentName+         :: AvailableTargetsMap (PackageId, ComponentName),++       availableTargetsByPackageId+         :: AvailableTargetsMap PackageId,++       availableTargetsByPackageName+         :: AvailableTargetsMap PackageName,++       availableTargetsByPackageNameAndComponentName+         :: AvailableTargetsMap (PackageName, ComponentName),++       availableTargetsByPackageNameAndUnqualComponentName+         :: AvailableTargetsMap (PackageName, UnqualComponentName)+     }+type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]++-- We define a bunch of indexes to help 'resolveTargets' with resolving+-- 'TargetSelector's to specific 'UnitId's.+--+-- They are all derived from the 'availableTargets' index.+-- The 'availableTargetsByPackageIdAndComponentName' is just that main index,+-- while the others are derived by re-grouping on the index key.+--+-- They are all constructed lazily because they are not necessarily all used.+--+availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes+availableTargetIndexes installPlan = AvailableTargetIndexes{..}+  where+    availableTargetsByPackageIdAndComponentName =+      availableTargets installPlan++    availableTargetsByPackageId =+                  Map.mapKeysWith+                    (++) (\(pkgid, _cname) -> pkgid)+                    availableTargetsByPackageIdAndComponentName+      `Map.union` availableTargetsEmptyPackages++    availableTargetsByPackageName =+      Map.mapKeysWith+        (++) packageName+        availableTargetsByPackageId++    availableTargetsByPackageNameAndComponentName =+      Map.mapKeysWith+        (++) (\(pkgid, cname) -> (packageName pkgid, cname))+        availableTargetsByPackageIdAndComponentName++    availableTargetsByPackageNameAndUnqualComponentName =+      Map.mapKeysWith+        (++) (\(pkgid, cname) -> let pname  = packageName pkgid+                                     cname' = unqualComponentName pname cname+                                  in (pname, cname'))+        availableTargetsByPackageIdAndComponentName+     where+       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.@@ -562,12 +678,15 @@ -- buildable and isn't a test suite or benchmark that is disabled. This -- can also be used to do these basic checks as part of a custom impl that ---selectComponentTargetBasic :: PackageId-                           -> ComponentName-                           -> SubComponentTarget+selectComponentTargetBasic :: SubComponentTarget                            -> AvailableTarget k                            -> Either TargetProblemCommon k-selectComponentTargetBasic pkgid cname subtarget AvailableTarget {..} =+selectComponentTargetBasic subtarget+                           AvailableTarget {+                             availableTargetPackageId     = pkgid,+                             availableTargetComponentName = cname,+                             availableTargetStatus+                           } =     case availableTargetStatus of       TargetDisabledByUser ->         Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget)@@ -590,6 +709,8 @@    | 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@@ -633,7 +754,10 @@           -> IO () printPlan verbosity           ProjectBaseContext {-            buildSettings = BuildTimeSettings{buildSettingDryRun}+            buildSettings = BuildTimeSettings{buildSettingDryRun},+            projectConfig = ProjectConfig {+              projectConfigLocalPackages = PackageConfig {packageConfigOptimization}+            }           }           ProjectBuildContext {             elaboratedPlanToExecute = elaboratedPlan,@@ -646,7 +770,7 @@    | otherwise   = noticeNoWrap verbosity $ unlines $-      ("In order, the following " ++ wouldWill ++ " be built" +++      (showBuildProfile ++ "In order, the following " ++ wouldWill ++ " be built" ++       ifNormal " (use -v for more details)" ++ ":")     : map showPkgAndReason pkgs @@ -690,7 +814,7 @@                     | (k,v) <- Map.toList (elabInstantiatedWith elab) ]      nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment-    nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab+    nonDefaultFlags elab = elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab      showStanzas pkg = concat                     $ [ " *test"@@ -705,7 +829,7 @@              ++ ")"      showFlagAssignment :: FlagAssignment -> String-    showFlagAssignment = concatMap ((' ' :) . showFlagValue)+    showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment      showConfigureFlags elab =         let fullConfigureFlags@@ -720,12 +844,7 @@             nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a             nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag             nubFlag _ f = f-            -- TODO: Closely logic from 'configureProfiling'.-            tryExeProfiling = Setup.fromFlagOrDefault False-                                (configProf fullConfigureFlags)-            tryLibProfiling = Setup.fromFlagOrDefault False-                                (Mon.mappend (configProf    fullConfigureFlags)-                                             (configProfExe fullConfigureFlags))+            (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling fullConfigureFlags             partialConfigureFlags               = Mon.mempty {                 configProf    =@@ -764,6 +883,14 @@     showMonitorChangedReason  MonitorFirstRun     = "first run"     showMonitorChangedReason  MonitorCorruptCache = "cannot read state cache" +    showBuildProfile = "Build profile: " ++ unwords [+      "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared,+      "-O" ++  (case packageConfigOptimization of+                Setup.Flag NoOptimisation      -> "0"+                Setup.Flag NormalOptimisation  -> "1"+                Setup.Flag MaximumOptimisation -> "2"+                Setup.NoFlag                   -> "1")]+      ++ "\n"  -- | If there are build failures then report them and throw an exception. --@@ -885,6 +1012,7 @@           ReplFailed      _ -> "repl failed for "    ++ pkgstr           HaddocksFailed  _ -> "Failed to build documentation for " ++ pkgstr           TestsFailed     _ -> "Tests failed for " ++ pkgstr+          BenchFailed     _ -> "Benchmarks failed for " ++ pkgstr           InstallFailed   _ -> "Failed to build "  ++ pkgstr           DependentFailed depid                             -> "Failed to build " ++ display (packageId pkg)@@ -968,6 +1096,7 @@         ReplFailed      e -> Just e         HaddocksFailed  e -> Just e         TestsFailed     e -> Just e+        BenchFailed     e -> Just e         InstallFailed   e -> Just e         DependentFailed _ -> Nothing @@ -987,4 +1116,3 @@  ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "  ++ "to get involved and help with testing, fixing bugs etc then\nthat "  ++ "is very much appreciated.\n"-

Distribution/Client/ProjectPlanOutput.hs view

@@ -10,7 +10,9 @@     -- | Several outputs rely on having a general overview of     PostBuildProjectStatus(..),     updatePostBuildProjectStatus,+    createPackageEnvironment,     writePlanGhcEnvironment,+    argsEquivalentOfGhcEnvironmentFile,   ) where  import           Distribution.Client.ProjectPlanning.Types@@ -29,10 +31,11 @@ import           Distribution.System import           Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.PackageDescription as PD-import           Distribution.Compiler (CompilerFlavor(GHC))+import           Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) import           Distribution.Simple.Compiler                    ( PackageDBStack, PackageDB(..)-                   , compilerVersion, compilerFlavor, showCompilerId )+                   , compilerVersion, compilerFlavor, showCompilerId+                   , compilerId, CompilerId(..), Compiler ) import           Distribution.Simple.GHC                    ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)                    , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile@@ -45,8 +48,9 @@ import           Distribution.Verbosity import qualified Paths_cabal_install as Our (version) -import           Data.Maybe (maybeToList, fromMaybe)-import           Data.Monoid+import Prelude ()+import Distribution.Client.Compat.Prelude+ import qualified Data.Map as Map import           Data.Set (Set) import qualified Data.Set as Set@@ -56,6 +60,7 @@ import           System.FilePath import           System.IO +import Distribution.Simple.Program.GHC (packageDbArgsDb)  ----------------------------------------------------------------------------- -- Writing plan.json files@@ -132,7 +137,7 @@         , "pkg-name"   J..= (jdisplay . pkgName . packageId) elab         , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab         , "flags"      J..= J.object [ PD.unFlagName fn J..= v-                                     | (fn,v) <- elabFlagAssignment elab ]+                                     | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ]         , "style"      J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))         ] ++         [ "pkg-src-sha256" J..= J.String (showHashValue hash)@@ -655,15 +660,52 @@     writeFileAtomic (distProjectCacheFile "up-to-date") $       Binary.encode upToDate +-- | Prepare a package environment that includes all the library dependencies+-- for a plan.+--+-- When running cabal new-exec, we want to set things up so that the compiler+-- can find all the right packages (and nothing else). This function is+-- intended to do that work. It takes a location where it can write files+-- temporarily, in case the compiler wants to learn this information via the+-- filesystem, and returns any environment variable overrides the compiler+-- needs.+createPackageEnvironment :: Verbosity+                         -> FilePath+                         -> ElaboratedInstallPlan+                         -> ElaboratedSharedConfig+                         -> PostBuildProjectStatus+                         -> IO [(String, Maybe String)]+createPackageEnvironment verbosity+                         path+                         elaboratedPlan+                         elaboratedShared+                         buildStatus+  | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC+  = do+    envFileM <- writePlanGhcEnvironment+      path+      elaboratedPlan+      elaboratedShared+      buildStatus+    case envFileM of+      Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)]+      Nothing -> do+        warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail"+        return []+  | otherwise+  = do+    warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"+    return []+ -- Writing .ghc.environment files -- -writePlanGhcEnvironment :: DistDirLayout+writePlanGhcEnvironment :: FilePath                         -> ElaboratedInstallPlan                         -> ElaboratedSharedConfig                         -> PostBuildProjectStatus-                        -> IO ()-writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory}+                        -> IO (Maybe FilePath)+writePlanGhcEnvironment path                         elaboratedInstallPlan                         ElaboratedSharedConfig {                           pkgConfigCompiler = compiler,@@ -673,26 +715,24 @@   | compilerFlavor compiler == GHC   , supportsPkgEnvFiles (getImplInfo compiler)   --TODO: check ghcjs compat-  --TODO: This feature is temporarily disabled due to #4010-  , False-  = writeGhcEnvironmentFile-      distProjectRootDirectory+  = fmap Just $ writeGhcEnvironmentFile+      path       platform (compilerVersion compiler)-      (renderGhcEnviromentFile distProjectRootDirectory-                               elaboratedInstallPlan-                               postBuildStatus)+      (renderGhcEnvironmentFile path+                                elaboratedInstallPlan+                                postBuildStatus)     --TODO: [required eventually] support for writing user-wide package     -- environments, e.g. like a global project, but we would not put the     -- env file in the home dir, rather it lives under ~/.ghc/ -writePlanGhcEnvironment _ _ _ _ = return ()+writePlanGhcEnvironment _ _ _ _ = return Nothing -renderGhcEnviromentFile :: FilePath-                        -> ElaboratedInstallPlan-                        -> PostBuildProjectStatus-                        -> [GhcEnvironmentFileEntry]-renderGhcEnviromentFile projectRootDir elaboratedInstallPlan-                        postBuildStatus =+renderGhcEnvironmentFile :: FilePath+                         -> ElaboratedInstallPlan+                         -> PostBuildProjectStatus+                         -> [GhcEnvironmentFileEntry]+renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan+                         postBuildStatus =     headerComment   : simpleGhcEnvironmentFile packageDBs unitIds   where@@ -703,11 +743,46 @@      ++ "But you still need to use cabal repl $target to get the environment\n"      ++ "of specific components (libs, exes, tests etc) because each one can\n"      ++ "have its own source dirs, cpp flags etc.\n\n"-    unitIds    = selectGhcEnviromentFileLibraries postBuildStatus+    unitIds    = selectGhcEnvironmentFileLibraries postBuildStatus     packageDBs = relativePackageDBPaths projectRootDir $-                 selectGhcEnviromentFilePackageDbs elaboratedInstallPlan+                 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan  +argsEquivalentOfGhcEnvironmentFile+  :: Compiler+  -> DistDirLayout+  -> ElaboratedInstallPlan+  -> PostBuildProjectStatus+  -> [String]+argsEquivalentOfGhcEnvironmentFile compiler =+  case compilerId compiler+  of CompilerId GHC   _ -> argsEquivalentOfGhcEnvironmentFileGhc+     CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc+     CompilerId _     _ -> error "Only GHC and GHCJS are supported"++-- TODO remove this when we drop support for non-.ghc.env ghc+argsEquivalentOfGhcEnvironmentFileGhc+  :: DistDirLayout+  -> ElaboratedInstallPlan+  -> PostBuildProjectStatus+  -> [String]+argsEquivalentOfGhcEnvironmentFileGhc+  distDirLayout+  elaboratedInstallPlan+  postBuildStatus =+    clearPackageDbStackFlag+ ++ packageDbArgsDb packageDBs+ ++ foldMap packageIdFlag packageIds+  where+    projectRootDir = distProjectRootDirectory distDirLayout+    packageIds = selectGhcEnvironmentFileLibraries postBuildStatus+    packageDBs = relativePackageDBPaths projectRootDir $+                 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan+    -- TODO use proper flags? but packageDbArgsDb is private+    clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]+    packageIdFlag uid = ["-package-id", display uid]++ -- We're producing an environment for users to use in ghci, so of course -- that means libraries only (can't put exes into the ghc package env!). -- The library environment should be /consistent/ with the environment@@ -740,10 +815,10 @@ -- to find the libs) then those exes still end up in our list so we have -- to filter them out at the end. ---selectGhcEnviromentFileLibraries :: PostBuildProjectStatus -> [UnitId]-selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} =+selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]+selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} =     case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of-      Nothing    -> error "renderGhcEnviromentFile: broken dep closure"+      Nothing    -> error "renderGhcEnvironmentFile: broken dep closure"       Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes                             , hasUpToDateLib pkg ]   where@@ -761,8 +836,8 @@        && installedUnitId pkg `Set.member` packagesProbablyUpToDate  -selectGhcEnviromentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack-selectGhcEnviromentFilePackageDbs elaboratedInstallPlan =+selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack+selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =     -- If we have any inplace packages then their package db stack is the     -- one we should use since it'll include the store + the local db but     -- it's certainly possible to have no local inplace packages@@ -775,7 +850,7 @@       case ordNub (map elabBuildPackageDBStack pkgs) of         [packageDbs] -> packageDbs         []           -> []-        _            -> error $ "renderGhcEnviromentFile: packages with "+        _            -> error $ "renderGhcEnvironmentFile: packages with "                              ++ "different package db stacks"         -- This should not happen at the moment but will happen as soon         -- as we support projects where we build packages with different

Distribution/Client/ProjectPlanning.hs view

@@ -51,11 +51,17 @@     setupHsReplArgs,     setupHsTestFlags,     setupHsTestArgs,+    setupHsBenchFlags,+    setupHsBenchArgs,     setupHsCopyFlags,     setupHsRegisterFlags,     setupHsHaddockFlags,      packageHashInputs,++    -- * Path construction+    binDirectoryFor,+    binDirectories   ) where  import Prelude ()@@ -74,6 +80,7 @@ import           Distribution.Client.Dependency import           Distribution.Client.Dependency.Types import qualified Distribution.Client.IndexUtils as IndexUtils+import           Distribution.Client.Init (incVersion) import           Distribution.Client.Targets (userToPackageConstraint) import           Distribution.Client.DistDirLayout import           Distribution.Client.SetupWrapper@@ -287,7 +294,8 @@ rebuildProjectConfig :: Verbosity                      -> DistDirLayout                      -> ProjectConfig-                     -> IO (ProjectConfig, [UnresolvedSourcePackage])+                     -> IO (ProjectConfig,+                            [PackageSpecifier UnresolvedSourcePackage]) rebuildProjectConfig verbosity                      distDirLayout@DistDirLayout {                        distProjectRootDirectory,@@ -308,6 +316,10 @@     return (projectConfig <> cliConfig, localPackages)    where+    ProjectConfigShared {+      projectConfigConfigFile+    } = projectConfigShared cliConfig+     fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config")      -- Read the cabal.project (or implicit config) and combine it with@@ -317,17 +329,22 @@     phaseReadProjectConfig = do       liftIO $ do         info verbosity "Project settings changed, reconfiguring..."-        createDirectoryIfMissingVerbose verbosity True distDirectory-        createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory--      readProjectConfig verbosity distDirLayout+      readProjectConfig verbosity projectConfigConfigFile distDirLayout      -- Look for all the cabal packages in the project     -- some of which may be local src dirs, tarballs etc     ---    phaseReadLocalPackages :: ProjectConfig -> Rebuild [UnresolvedSourcePackage]+    phaseReadLocalPackages :: ProjectConfig+                           -> Rebuild [PackageSpecifier UnresolvedSourcePackage]     phaseReadLocalPackages projectConfig = do       localCabalFiles <- findProjectPackages distDirLayout projectConfig++      -- Create folder only if findProjectPackages did not throw a+      -- BadPackageLocations exception.+      liftIO $ do+        createDirectoryIfMissingVerbose verbosity True distDirectory+        createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory+       mapM (readSourcePackage verbosity) localCabalFiles  @@ -347,7 +364,7 @@ rebuildInstallPlan :: Verbosity                    -> DistDirLayout -> CabalDirLayout                    -> ProjectConfig-                   -> [UnresolvedSourcePackage]+                   -> [PackageSpecifier UnresolvedSourcePackage]                    -> IO ( ElaboratedInstallPlan  -- with store packages                          , ElaboratedInstallPlan  -- with source packages                          , ElaboratedSharedConfig )@@ -499,7 +516,7 @@     --     phaseRunSolver :: ProjectConfig                    -> (Compiler, Platform, ProgramDb)-                   -> [UnresolvedSourcePackage]+                   -> [PackageSpecifier UnresolvedSourcePackage]                    -> Rebuild (SolverInstallPlan, PkgConfigDb)     phaseRunSolver projectConfig@ProjectConfig {                      projectConfigShared,@@ -547,7 +564,7 @@           Map.fromList             [ (pkgname, stanzas)             | pkg <- localPackages-            , let pkgname            = packageName pkg+            , let pkgname            = pkgSpecifierTarget pkg                   testsEnabled       = lookupLocalPackageConfig                                          packageConfigTests                                          projectConfig pkgname@@ -569,11 +586,12 @@                        -> (Compiler, Platform, ProgramDb)                        -> PkgConfigDb                        -> SolverInstallPlan-                       -> [SourcePackage loc]+                       -> [PackageSpecifier (SourcePackage loc)]                        -> Rebuild ( ElaboratedInstallPlan                                   , ElaboratedSharedConfig )     phaseElaboratePlan ProjectConfig {                          projectConfigShared,+                         projectConfigAllPackages,                          projectConfigLocalPackages,                          projectConfigSpecificPackage,                          projectConfigBuildOnly@@ -601,6 +619,7 @@                 sourcePackageHashes                 defaultInstallDirs                 projectConfigShared+                projectConfigAllPackages                 projectConfigLocalPackages                 (getMapMappend projectConfigSpecificPackage)         let instantiatedPlan = instantiateInstallPlan elaboratedPlan@@ -705,7 +724,7 @@ -}  getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)-                  -> IndexUtils.IndexState -> Rebuild SourcePackageDb+                  -> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb getSourcePackages verbosity withRepoCtx idxState = do     (sourcePkgDb, repos) <-       liftIO $@@ -714,9 +733,9 @@                                                                   repoctx idxState           return (sourcePkgDb, repoContextRepos repoctx) -    monitorFiles . map monitorFile-                 . IndexUtils.getSourcePackagesMonitorFiles-                 $ repos+    mapM_ needIfExists+        . IndexUtils.getSourcePackagesMonitorFiles+        $ repos     return sourcePkgDb  @@ -878,7 +897,7 @@              -> InstalledPackageIndex              -> SourcePackageDb              -> PkgConfigDb-             -> [UnresolvedSourcePackage]+             -> [PackageSpecifier UnresolvedSourcePackage]              -> Map PackageName (Map OptionalStanza Bool)              -> Progress String String SolverInstallPlan planPackages verbosity comp platform solver SolverSettings{..}@@ -898,8 +917,7 @@          setMaxBackjumps solverSettingMaxBackjumps -        --TODO: [required eventually] should only be configurable for custom installs-   -- . setIndependentGoals solverSettingIndependentGoals+      . setIndependentGoals solverSettingIndependentGoals        . setReorderGoals solverSettingReorderGoals @@ -932,18 +950,8 @@                                    . PD.packageDescription                                    . packageDescription) -      . addSetupCabalMinVersionConstraint (mkVersion [1,20])-          -- While we can talk to older Cabal versions (we need to be able to-          -- do so for custom Setup scripts that require older Cabal lib-          -- versions), we have problems talking to some older versions that-          -- don't support certain features.-          ---          -- For example, Cabal-1.16 and older do not know about build targets.-          -- Even worse, 1.18 and older only supported the --constraint flag-          -- with source package ids, not --dependency with installed package-          -- ids. That is bad because we cannot reliably select the right-          -- dependencies in the presence of multiple instances (i.e. the-          -- store). See issue #3932. So we require Cabal 1.20 as a minimum.+      . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint+      . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint        . addPreferences           -- preferences from the config file or command line@@ -959,7 +967,7 @@           -- enable stanza preference where the user did not specify           [ PackageStanzasPreference pkgname stanzas           | pkg <- localPackages-          , let pkgname = packageName pkg+          , let pkgname = pkgSpecifierTarget pkg                 stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable                 stanzas = [ stanza | stanza <- [minBound..maxBound]                           , Map.lookup stanza stanzaM == Nothing ]@@ -973,7 +981,7 @@                                  (PackagePropertyStanzas stanzas))               ConstraintSourceConfigFlagOrTarget           | pkg <- localPackages-          , let pkgname = packageName pkg+          , let pkgname = pkgSpecifierTarget pkg                 stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable                 stanzas = [ stanza | stanza <- [minBound..maxBound]                           , Map.lookup stanza stanzaM == Just True ]@@ -999,9 +1007,9 @@                                  (PackagePropertyFlags flags))               ConstraintSourceConfigFlagOrTarget           | let flags = solverSettingFlagAssignment-          , not (null flags)+          , not (PD.nullFlagAssignment flags)           , pkg <- localPackages-          , let pkgname = packageName pkg ]+          , let pkgname = pkgSpecifierTarget pkg ]        $ stdResolverParams @@ -1010,9 +1018,73 @@       -- its own addDefaultSetupDependencies that is not appropriate for us.       basicInstallPolicy         installedPkgIndex sourcePkgDb-        (map SpecificSourcePackage localPackages)+        localPackages +    -- While we can talk to older Cabal versions (we need to be able to+    -- do so for custom Setup scripts that require older Cabal lib+    -- versions), we have problems talking to some older versions that+    -- don't support certain features.+    --+    -- For example, Cabal-1.16 and older do not know about build targets.+    -- Even worse, 1.18 and older only supported the --constraint flag+    -- with source package ids, not --dependency with installed package+    -- ids. That is bad because we cannot reliably select the right+    -- dependencies in the presence of multiple instances (i.e. the+    -- store). See issue #3932. So we require Cabal 1.20 as a minimum.+    --+    -- Moreover, lib:Cabal generally only supports the interface of+    -- 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+    -- 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.2+    -- GHC 8.2   needs  Cabal >= 2.0+    -- GHC 8.0   needs  Cabal >= 1.24+    -- GHC 7.10  needs  Cabal >= 1.22+    --+    -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is+    -- the absolute lower bound)+    --+    -- TODO: long-term, this compatibility matrix should be+    --       stored as a field inside 'Distribution.Compiler.Compiler'+    setupMinCabalVersionConstraint+      | isGHC, compVer >= mkVersion [8,4,1] = mkVersion [2,2]+        -- GHC 8.4.1-rc1 (GHC 8.4.0.20180224) still shipped with an+        -- devel snapshot of Cabal-2.1.0.0; the rule below can be+        -- dropped at some point+      | isGHC, compVer >= mkVersion [8,4]  = mkVersion [2,1]+      | isGHC, compVer >= mkVersion [8,2]  = mkVersion [2,0]+      | isGHC, compVer >= mkVersion [8,0]  = mkVersion [1,24]+      | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22]+      | otherwise                          = mkVersion [1,20]+      where+        isGHC    = compFlav `elem` [GHC,GHCJS]+        compFlav = compilerFlavor comp+        compVer  = compilerVersion comp +    -- As we can't predict the future, we also place a global upper+    -- bound on the lib:Cabal version we know how to interact with:+    --+    -- The upper bound is computed by incrementing the current major+    -- version twice in order to allow for the current version, as+    -- well as the next adjacent major version (one of which will not+    -- be released, as only "even major" versions of Cabal are+    -- released to Hackage or bundled with proper GHC releases).+    --+    -- For instance, if the current version of cabal-install is an odd+    -- development version, e.g.  Cabal-2.1.0.0, then we impose an+    -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a+    -- stable/release even version, e.g. Cabal-2.2.1.0, the upper+    -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility+    -- when dealing with development snapshots of Cabal and cabal-install.+    --+    setupMaxCabalVersionConstraint =+      alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion+ ------------------------------------------------------------------------------ -- * Install plan post-processing ------------------------------------------------------------------------------@@ -1122,20 +1194,22 @@   -> DistDirLayout   -> StoreDirLayout   -> SolverInstallPlan-  -> [SourcePackage loc]+  -> [PackageSpecifier (SourcePackage loc)]   -> Map PackageId PackageSourceHash   -> InstallDirs.InstallDirTemplates   -> ProjectConfigShared   -> PackageConfig+  -> PackageConfig   -> Map PackageName PackageConfig   -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB-                     DistDirLayout{..}+                     distDirLayout@DistDirLayout{..}                      storeDirLayout@StoreDirLayout{storePackageDBStack}                      solverPlan localPackages                      sourcePackageHashes                      defaultInstallDirs                      sharedPackageConfig+                     allPackagesConfig                      localPackagesConfig                      perPackageConfig = do     x <- elaboratedInstallPlan@@ -1191,7 +1265,7 @@             if null not_per_component_reasons                 then return comps                 else do checkPerPackageOk comps not_per_component_reasons-                        return [elaborateSolverToPackage mapDep spkg g $+                        return [elaborateSolverToPackage spkg g $                                 comps ++ maybeToList setupComponent]            Left cns ->             dieProgress $@@ -1200,19 +1274,24 @@       where         -- You are eligible to per-component build if this list is empty         why_not_per_component g-            = cuz_custom ++ cuz_spec ++ cuz_length ++ cuz_flag+            = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage           where             cuz reason = [text reason]-            -- At this point in time, only non-Custom setup scripts+            -- We have to disable per-component for now with+            -- Configure-type scripts in order to prevent parallel+            -- invocation of the same `./configure` script.+            -- See https://github.com/haskell/cabal/issues/4548+            --+            -- Moreoever, at this point in time, only non-Custom setup scripts             -- are supported.  Implementing per-component builds with             -- Custom would require us to create a new 'ElabSetup'             -- type, and teach all of the code paths how to handle it.             -- Once you've implemented this, swap it for the code below.-            cuz_custom =+            cuz_buildtype =                 case PD.buildType (elabPkgDescription elab0) of-                    Nothing        -> cuz "build-type is not specified"-                    Just PD.Custom -> cuz "build-type is Custom"-                    Just _         -> []+                    PD.Configure -> cuz "build-type is Configure"+                    PD.Custom -> cuz "build-type is Custom"+                    _         -> []             -- cabal-format versions prior to 1.8 have different build-depends semantics             -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8             -- see, https://github.com/haskell/cabal/issues/4121@@ -1232,6 +1311,12 @@                 | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig)                 = []                 | otherwise = cuz "you passed --disable-per-component"+            -- Enabling program coverage introduces odd runtime dependencies+            -- between components.+            cuz_coverage+                | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig)+                = cuz "program coverage is enabled"+                | otherwise = []          -- | Sometimes a package may make use of features which are only         -- supported in per-package mode.  If this is the case, we should@@ -1246,7 +1331,7 @@                         fsep (punctuate comma reasons)             -- TODO: Maybe exclude Backpack too -        elab0 = elaborateSolverToCommon mapDep spkg+        elab0 = elaborateSolverToCommon spkg         pkgid = elabPkgSourceId    elab0         pd    = elabPkgDescription elab0 @@ -1256,7 +1341,7 @@         -- have to add dependencies on this from all other components         setupComponent :: Maybe ElaboratedConfiguredPackage         setupComponent-            | fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) == PD.Custom+            | PD.buildType (elabPkgDescription elab0) == PD.Custom             = Just elab0 {                 elabModuleShape = emptyModuleShape,                 elabUnitId = notImpl "elabUnitId",@@ -1435,22 +1520,16 @@                   (compilerId compiler)                   cid -            -- NB: For inplace NOT InstallPaths.bindir installDirs; for an-            -- inplace build those values are utter nonsense.  So we-            -- have to guess where the directory is going to be.-            -- Fortunately this is "stable" part of Cabal API.-            -- But the way we get the build directory is A HORRIBLE-            -- HACK.-            inplace_bin_dir elab-              | shouldBuildInplaceOnly spkg-              = distBuildDirectory-                    (elabDistDirParams elaboratedSharedConfig elab) </>-                    "build" </> case Cabal.componentNameString cname of-                                    Just n -> display n-                                    Nothing -> ""-              | otherwise-              = InstallDirs.bindir (elabInstallDirs elab)+            inplace_bin_dir elab =+                binDirectoryFor+                    distDirLayout+                    elaboratedSharedConfig+                    elab $+                    case Cabal.componentNameString cname of+                             Just n -> display n+                             Nothing -> "" +     -- | Given a 'SolverId' referencing a dependency on a library, return     -- the 'ElaboratedPlanPackage' corresponding to the library.  This     -- returns at most one result.@@ -1464,28 +1543,24 @@     planPackageExePath =         -- Pre-existing executables are assumed to be in PATH         -- already.  In fact, this should be impossible.-        -- Modest duplication with 'inplace_bin_dir'         InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $-            if elabBuildStyle elab == BuildInplaceOnly-              then distBuildDirectory-                    (elabDistDirParams elaboratedSharedConfig elab) </>-                    "build" </>-                        case elabPkgOrComp elab of-                            ElabPackage _ -> ""-                            ElabComponent comp ->-                                case fmap Cabal.componentNameString-                                          (compComponentName comp) of-                                    Just (Just n) -> display n-                                    _ -> ""-              else InstallDirs.bindir (elabInstallDirs elab)+            binDirectoryFor+                distDirLayout+                elaboratedSharedConfig+                elab $+                    case elabPkgOrComp elab of+                        ElabPackage _ -> ""+                        ElabComponent comp ->+                            case fmap Cabal.componentNameString+                                      (compComponentName comp) of+                                Just (Just n) -> display n+                                _ -> "" -    elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage])-                             -> SolverPackage UnresolvedPkgLoc+    elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc                              -> ComponentsGraph                              -> [ElaboratedConfiguredPackage]                              -> ElaboratedConfiguredPackage     elaborateSolverToPackage-        mapDep         pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride)                            _flags _stanzas _deps0 _exe_deps0)         compGraph comps =@@ -1494,7 +1569,7 @@         -- of the other fields of the elaboratedPackage.         elab       where-        elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg+        elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg         elab = elab0 {                 elabUnitId = newSimpleUnitId pkgInstalledId,                 elabComponentId = pkgInstalledId,@@ -1557,8 +1632,14 @@                             } <- comps                           ] -        -- Filled in later-        pkgStanzasEnabled  = Set.empty+        -- NB: This is not the final setting of 'pkgStanzasEnabled'.+        -- See [Sticky enabled testsuites]; we may enable some extra+        -- stanzas opportunistically when it is cheap to do so.+        --+        -- However, we start off by enabling everything that was+        -- requested, so that we can maintain an invariant that+        -- pkgStanzasEnabled is a superset of elabStanzasRequested+        pkgStanzasEnabled  = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested)          install_dirs           | shouldBuildInplaceOnly pkg@@ -1585,10 +1666,9 @@               (compilerId compiler)               pkgInstalledId -    elaborateSolverToCommon :: (SolverId -> [ElaboratedPlanPackage])-                            -> SolverPackage UnresolvedPkgLoc+    elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc                             -> ElaboratedConfiguredPackage-    elaborateSolverToCommon mapDep+    elaborateSolverToCommon         pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride)                            flags stanzas deps0 _exe_deps0) =         elaboratedPackage@@ -1613,7 +1693,8 @@                                     [] gdesc                                in desc         elabFlagAssignment  = flags-        elabFlagDefaults    = [ (Cabal.flagName flag, Cabal.flagDefault flag)+        elabFlagDefaults    = PD.mkFlagAssignment+                              [ (Cabal.flagName flag, Cabal.flagDefault flag)                               | flag <- PD.genPackageFlags gdesc ]          elabEnabledSpec      = enableStanzas stanzas@@ -1644,8 +1725,10 @@         -- Check the comments of those functions for more details.         elabBuildTargets    = []         elabTestTargets     = []+        elabBenchTargets    = []         elabReplTarget      = Nothing-        elabBuildHaddocks   = False+        elabBuildHaddocks   =+          perPkgOptionFlag pkgid False packageConfigDocumentation          elabPkgSourceLocation = srcloc         elabPkgSourceHash   = Map.lookup pkgid sourcePackageHashes@@ -1656,10 +1739,9 @@         elabRegisterPackageDBStack = buildAndRegisterDbs          elabSetupScriptStyle       = packageSetupScriptStyle elabPkgDescription-        -- Computing the deps here is a little awful-        deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0-        elabSetupScriptCliVersion  = packageSetupScriptSpecVersion-                                      elabSetupScriptStyle elabPkgDescription deps+        elabSetupScriptCliVersion  =+          packageSetupScriptSpecVersion+          elabSetupScriptStyle elabPkgDescription libDepGraph deps0         elabSetupPackageDBStack    = buildAndRegisterDbs          buildAndRegisterDbs@@ -1670,6 +1752,7 @@          elabVanillaLib    = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively         elabSharedLib     = pkgid `Set.member` pkgsUseSharedLibrary+        elabStaticLib     = perPkgOptionFlag pkgid False packageConfigStaticLib         elabDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe         elabGHCiLib       = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still @@ -1684,6 +1767,7 @@          elabOptimization  = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization         elabSplitObjs     = perPkgOptionFlag pkgid False packageConfigSplitObjs+        elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections         elabStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs         elabStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes         elabDebugInfo     = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo@@ -1717,12 +1801,13 @@         elabHaddockHtml         = perPkgOptionFlag pkgid False packageConfigHaddockHtml         elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation         elabHaddockForeignLibs  = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs+        elabHaddockForHackage   = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage         elabHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables         elabHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites         elabHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks         elabHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal         elabHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss-        elabHaddockHscolour     = perPkgOptionFlag pkgid False packageConfigHaddockHscolour+        elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource         elabHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss         elabHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents @@ -1747,14 +1832,17 @@      lookupPerPkgOption :: (Package pkg, Monoid m)                        => pkg -> (PackageConfig -> m) -> m-    lookupPerPkgOption pkg f-      -- the project config specifies values that apply to packages local to-      -- but by default non-local packages get all default config values-      -- the project, and can specify per-package values for any package,-      | isLocalToProject pkg = local `mappend` perpkg-      | otherwise            =                 perpkg+    lookupPerPkgOption pkg f =+        -- This is where we merge the options from the project config that+        -- apply to all packages, all project local packages, and to specific+        -- named packages+        global `mappend` local `mappend` perpkg       where-        local  = f localPackagesConfig+        global = f allPackagesConfig+        local  | isLocalToProject pkg+               = f localPackagesConfig+               | otherwise+               = mempty         perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)      inplacePackageDbs = storePackageDbs@@ -1776,15 +1864,25 @@       $ map packageId       $ SolverInstallPlan.reverseDependencyClosure           solverPlan-          [ PlannedId (packageId pkg)-          | pkg <- localPackages ]+          (map PlannedId (Set.toList pkgsLocalToProject))      isLocalToProject :: Package pkg => pkg -> Bool     isLocalToProject pkg = Set.member (packageId pkg)                                       pkgsLocalToProject      pkgsLocalToProject :: Set PackageId-    pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ]+    pkgsLocalToProject =+        Set.fromList (catMaybes (map shouldBeLocal localPackages))+        --TODO: localPackages is a misnomer, it's all project packages+        -- here is where we decide which ones will be local!+      where+        shouldBeLocal :: PackageSpecifier (SourcePackage loc) -> Maybe PackageId+        shouldBeLocal NamedPackage{}              = Nothing+        shouldBeLocal (SpecificSourcePackage pkg) = Just (packageId pkg)+        -- TODO: It's not actually obvious for all of the+        -- 'ProjectPackageLocation's that they should all be local. We might+        -- need to provide the user with a choice.+        -- Also, review use of SourcePackage's loc vs ProjectPackageLocation      pkgsUseSharedLibrary :: Set PackageId     pkgsUseSharedLibrary =@@ -1925,6 +2023,35 @@             (Map.fromList [ (req, OpenModuleVar req)                           | req <- Set.toList (modShapeRequires shape)]) +-- | Get the bin\/ directories that a package's executables should reside in.+--+-- The result may be empty if the package does not build any executables.+--+-- The result may have several entries if this is an inplace build of a package+-- with multiple executables.+binDirectories+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedConfiguredPackage+  -> [FilePath]+binDirectories layout config package = case elabBuildStyle package of+  -- quick sanity check: no sense returning a bin directory if we're not going+  -- to put any executables in it, that will just clog up the PATH+  _ | noExecutables -> []+  BuildAndInstall -> [installedBinDirectory package]+  BuildInplaceOnly -> map (root</>) $ case elabPkgOrComp package of+    ElabComponent comp -> case compSolverName comp of+      CD.ComponentExe n -> [display n]+      _ -> []+    ElabPackage _ -> map (display . PD.exeName)+                   . PD.executables+                   . elabPkgDescription+                   $ package+  where+  noExecutables = null . PD.executables . elabPkgDescription $ package+  root  =  distBuildDirectory layout (elabDistDirParams config package)+       </> "build"+ -- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the -- dependency graph considers only dependencies on libraries which are -- NOT from setup dependencies.  Used to compute the set@@ -2309,6 +2436,7 @@ pkgHasEphemeralBuildTargets elab =     isJust (elabReplTarget elab)  || (not . null) (elabTestTargets elab)+ || (not . null) (elabBenchTargets elab)  || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab                       , subtarget /= WholeComponent ] @@ -2334,6 +2462,7 @@ data TargetAction = TargetActionBuild                   | TargetActionRepl                   | TargetActionTest+                  | TargetActionBench                   | TargetActionHaddock  -- | Given a set of per-package\/per-component targets, take the subset of the@@ -2341,6 +2470,10 @@ -- to specify which optional stanzas to enable, and which targets within each -- package to build. --+-- NB: Pruning happens after improvement, which is important because we+-- will prune differently depending on what is already installed (to+-- implement "sticky" test suite enabling behavior).+-- pruneInstallPlanToTargets :: TargetAction                           -> Map UnitId [ComponentTarget]                           -> ElaboratedInstallPlan -> ElaboratedInstallPlan@@ -2401,6 +2534,7 @@         (Nothing, _)                      -> elab         (Just tgts,  TargetActionBuild)   -> elab { elabBuildTargets = tgts }         (Just tgts,  TargetActionTest)    -> elab { elabTestTargets  = tgts }+        (Just tgts,  TargetActionBench)   -> elab { elabBenchTargets  = tgts }         (Just [tgt], TargetActionRepl)    -> elab { elabReplTarget = Just tgt }         (Just _,     TargetActionHaddock) -> elab { elabBuildHaddocks = True }         (Just _,     TargetActionRepl)    ->@@ -2426,19 +2560,20 @@     roots = mapMaybe find_root pkgs'      prune elab = PrunedPackage elab' (pruneOptionalDependencies elab')-      where elab' = pruneOptionalStanzas elab+      where elab' = addOptionalStanzas elab      find_root (InstallPlan.Configured (PrunedPackage elab _)) =         if not (null (elabBuildTargets elab)                     && null (elabTestTargets elab)+                    && null (elabBenchTargets elab)                     && isNothing (elabReplTarget elab)                     && not (elabBuildHaddocks elab))             then Just (installedUnitId elab)             else Nothing     find_root _ = Nothing -    -- Decide whether or not to enable testsuites and benchmarks-    --+    -- Note [Sticky enabled testsuites]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~     -- The testsuite and benchmark targets are somewhat special in that we need     -- to configure the packages with them enabled, and we need to do that even     -- if we only want to build one of several testsuites.@@ -2452,18 +2587,31 @@     -- would involve unnecessarily reconfiguring the package with testsuites     -- disabled. Technically this introduces a little bit of stateful     -- behaviour to make this "sticky", but it should be benign.-    ---    pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage-    pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } =++    -- Decide whether or not to enable testsuites and benchmarks.+    -- See [Sticky enabled testsuites]+    addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage+    addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } =         elab {             elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas })         }       where         stanzas :: Set OptionalStanza-        stanzas = optionalStanzasRequiredByTargets  elab-               <> optionalStanzasRequestedByDefault elab+               -- By default, we enabled all stanzas requested by the user,+               -- as per elabStanzasRequested, done in+               -- 'elaborateSolverToPackage'+        stanzas = pkgStanzasEnabled pkg+               -- optionalStanzasRequiredByTargets has to be done at+               -- prune-time because it depends on 'elabTestTargets'+               -- et al, which is done by 'setRootTargets' at the+               -- beginning of pruning.+               <> optionalStanzasRequiredByTargets elab+               -- optionalStanzasWithDepsAvailable has to be done at+               -- prune-time because it depends on what packages are+               -- installed, which is not known until after improvement+               -- (pruning is done after improvement)                <> optionalStanzasWithDepsAvailable availablePkgs elab pkg-    pruneOptionalStanzas elab = elab+    addOptionalStanzas elab = elab      -- Calculate package dependencies but cut out those needed only by     -- optional stanzas that we've determined we will not enable.@@ -2489,17 +2637,11 @@         [ stanza         | ComponentTarget cname _ <- elabBuildTargets pkg                                   ++ elabTestTargets pkg+                                  ++ elabBenchTargets pkg                                   ++ maybeToList (elabReplTarget pkg)         , stanza <- maybeToList (componentOptionalStanza cname)         ] -    optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage-                                      -> Set OptionalStanza-    optionalStanzasRequestedByDefault =-        Map.keysSet-      . Map.filter (id :: Bool -> Bool)-      . elabStanzasRequested-     availablePkgs =       Set.fromList         [ installedUnitId pkg@@ -2668,7 +2810,7 @@             Left $ CannotPruneDependencies              [ (pkg, missingDeps)              | (pkg, missingDepIds) <- brokenPackages-             , let missingDeps = catMaybes (map lookupDep missingDepIds)+             , let missingDeps = mapMaybe lookupDep missingDepIds              ]             where               -- lookup in the original unpruned graph@@ -2739,7 +2881,7 @@   | otherwise   = SetupNonCustomInternalLib   where-    buildType = fromMaybe PD.Custom (PD.buildType pkg)+    buildType = PD.buildType pkg   -- | Part of our Setup.hs handling policy is implemented by getting the solver@@ -2819,31 +2961,34 @@ -- of what the solver picked for us, based on the explicit setup deps or the -- ones added implicitly by 'defaultSetupDeps'. ---packageSetupScriptSpecVersion :: Package pkg-                              => SetupScriptStyle+packageSetupScriptSpecVersion :: SetupScriptStyle                               -> PD.PackageDescription-                              -> ComponentDeps [pkg]+                              -> Graph.Graph NonSetupLibDepSolverPlanPackage+                              -> ComponentDeps [SolverId]                               -> Version  -- We're going to be using the internal Cabal library, so the spec version of -- that is simply the version of the Cabal library that cabal-install has been -- built with.-packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ =+packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ =     cabalVersion  -- If we happen to be building the Cabal lib itself then because that -- bootstraps itself then we use the version of the lib we're building.-packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _+packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _   | packageName pkg == cabalPkgname   = packageVersion pkg  -- In all other cases we have a look at what version of the Cabal lib the -- solver picked. Or if it didn't depend on Cabal at all (which is very rare) -- then we look at the .cabal file to see what spec version it declares.-packageSetupScriptSpecVersion _ pkg deps =-    case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of+packageSetupScriptSpecVersion _ pkg libDepGraph deps =+    case find ((cabalPkgname ==) . packageName) setupLibDeps of       Just dep -> packageVersion dep       Nothing  -> PD.specVersion pkg+  where+    setupLibDeps = map packageId $ fromMaybe [] $+                   Graph.closure libDepGraph (CD.setupDeps deps)   cabalPkgname, basePkgname :: PackageName@@ -2875,6 +3020,7 @@ -- in the store and local dbs.  setupHsScriptOptions :: ElaboratedReadyPackage+                     -> ElaboratedInstallPlan                      -> ElaboratedSharedConfig                      -> FilePath                      -> FilePath@@ -2884,7 +3030,7 @@ -- TODO: Fix this so custom is a separate component.  Custom can ALWAYS -- be a separate component!!! setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..})-                     ElaboratedSharedConfig{..} srcdir builddir+                     plan ElaboratedSharedConfig{..} srcdir builddir                      isParallelBuild cacheLock =     SetupScriptOptions {       useCabalVersion          = thisVersion elabSetupScriptCliVersion,@@ -2903,6 +3049,7 @@       useLoggingHandle         = Nothing, -- this gets set later       useWorkingDir            = Just srcdir,       useExtraPathEnv          = elabExeDependencyPaths elab,+      useExtraEnvOverrides     = dataDirsEnvironmentForPlan plan,       useWin32CleanHack        = False,   --TODO: [required eventually]       forceExternalSetupMethod = isParallelBuild,       setupCacheLock           = Just cacheLock,@@ -2926,15 +3073,22 @@                         -> CompilerId                         -> InstalledPackageId                         -> InstallDirs.InstallDirs FilePath-storePackageInstallDirs StoreDirLayout{storePackageDirectory}+storePackageInstallDirs StoreDirLayout{ storePackageDirectory+                                      , storeDirectory }                         compid ipkgid =     InstallDirs.InstallDirs {..}   where+    store        = storeDirectory compid     prefix       = storePackageDirectory compid (newSimpleUnitId ipkgid)     bindir       = prefix </> "bin"     libdir       = prefix </> "lib"     libsubdir    = ""-    dynlibdir    = libdir+    -- Note: on macOS, we place libraries into+    --       @store/lib@ to work around the load+    --       command size limit of macOSs mach-o linker.+    --       See also @PackageHash.hashedInstalledPackageIdVeryShort@+    dynlibdir    | buildOS == OSX = store </> "lib"+                 | otherwise      = libdir     flibdir      = libdir     libexecdir   = prefix </> "libexec"     libexecsubdir= ""@@ -2980,7 +3134,25 @@                                   ElabComponent _ -> toFlag elabComponentId      configProgramPaths        = Map.toList elabProgramPaths-    configProgramArgs         = Map.toList elabProgramArgs+    configProgramArgs+        | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True+          -- workaround for <https://github.com/haskell/cabal/issues/4010>+          --+          -- It turns out, that even with Cabal 2.0, there's still cases such as e.g.+          -- custom Setup.hs scripts calling out to GHC even when going via+          -- @runProgram ghcProgram@, as e.g. happy does in its+          -- <http://hackage.haskell.org/package/happy-1.19.5/src/Setup.lhs>+          -- (see also <https://github.com/haskell/cabal/pull/4433#issuecomment-299396099>)+          --+          -- So for now, let's pass the rather harmless and idempotent+          -- `-hide-all-packages` flag to all invocations (which has+          -- the benefit that every GHC invocation starts with a+          -- conistently well-defined clean slate) until we find a+          -- better way.+                              = Map.toList $+                                Map.insertWith (++) "ghc" ["-hide-all-packages"]+                                               elabProgramArgs+        | otherwise           = Map.toList elabProgramArgs     configProgramPathExtra    = toNubList elabProgramPathExtra     configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)     configHcPath              = mempty -- we use configProgramPaths instead@@ -2988,6 +3160,8 @@      configVanillaLib          = toFlag elabVanillaLib     configSharedLib           = toFlag elabSharedLib+    configStaticLib           = toFlag elabStaticLib+     configDynExe              = toFlag elabDynExe     configGHCiLib             = toFlag elabGHCiLib     configProfExe             = mempty@@ -3003,12 +3177,11 @@     configLibCoverage         = mempty      configOptimization        = toFlag elabOptimization+    configSplitSections       = toFlag elabSplitSections     configSplitObjs           = toFlag elabSplitObjs     configStripExes           = toFlag elabStripExes     configStripLibs           = toFlag elabStripLibs     configDebugInfo           = toFlag elabDebugInfo-    configAllowOlder          = mempty -- we use configExactConfiguration True-    configAllowNewer          = mempty -- we use configExactConfiguration True      configConfigurationsFlags = elabFlagAssignment     configConfigureArgs       = elabConfigureScriptArgs@@ -3059,7 +3232,7 @@     configScratchDir          = mempty -- never use     configUserInstall         = mempty -- don't rely on defaults     configPrograms_           = mempty -- never use, shouldn't exist-+    configUseResponseFiles    = mempty  setupHsConfigureArgs :: ElaboratedConfiguredPackage                      -> [String]@@ -3082,7 +3255,8 @@       buildVerbosity    = toFlag verbosity,       buildDistPref     = toFlag builddir,       buildNumJobs      = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),-      buildArgs         = mempty  -- unused, passed via args not flags+      buildArgs         = mempty, -- unused, passed via args not flags+      buildCabalFilePath= mempty     }  @@ -3117,6 +3291,23 @@ setupHsTestArgs elab =     mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) ++setupHsBenchFlags :: ElaboratedConfiguredPackage+                  -> ElaboratedSharedConfig+                  -> Verbosity+                  -> FilePath+                  -> Cabal.BenchmarkFlags+setupHsBenchFlags _ _ verbosity builddir = Cabal.BenchmarkFlags+    { benchmarkDistPref  = toFlag builddir+    , benchmarkVerbosity = toFlag verbosity+    , benchmarkOptions   = mempty+    }++setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String]+setupHsBenchArgs elab =+    mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab)++ setupHsReplFlags :: ElaboratedConfiguredPackage                  -> ElaboratedSharedConfig                  -> Verbosity@@ -3149,7 +3340,8 @@       copyArgs      = [], -- TODO: could use this to only copy what we enabled       copyDest      = toFlag (InstallDirs.CopyTo destdir),       copyDistPref  = toFlag builddir,-      copyVerbosity = toFlag verbosity+      copyVerbosity = toFlag verbosity,+      copyCabalFilePath = mempty     }  setupHsRegisterFlags :: ElaboratedConfiguredPackage@@ -3170,7 +3362,8 @@       regPrintId     = mempty,  -- never use       regDistPref    = toFlag builddir,       regArgs        = [],-      regVerbosity   = toFlag verbosity+      regVerbosity   = toFlag verbosity,+      regCabalFilePath = mempty     }  setupHsHaddockFlags :: ElaboratedConfiguredPackage@@ -3187,19 +3380,20 @@       haddockHoogle        = toFlag elabHaddockHoogle,       haddockHtml          = toFlag elabHaddockHtml,       haddockHtmlLocation  = maybe mempty toFlag elabHaddockHtmlLocation,-      haddockForHackage    = mempty, --TODO: new flag+      haddockForHackage    = toFlag elabHaddockForHackage,       haddockForeignLibs   = toFlag elabHaddockForeignLibs,       haddockExecutables   = toFlag elabHaddockExecutables,       haddockTestSuites    = toFlag elabHaddockTestSuites,       haddockBenchmarks    = toFlag elabHaddockBenchmarks,       haddockInternal      = toFlag elabHaddockInternal,       haddockCss           = maybe mempty toFlag elabHaddockCss,-      haddockHscolour      = toFlag elabHaddockHscolour,+      haddockLinkedSource  = toFlag elabHaddockLinkedSource,       haddockHscolourCss   = maybe mempty toFlag elabHaddockHscolourCss,       haddockContents      = maybe mempty toFlag elabHaddockContents,       haddockDistPref      = toFlag builddir,       haddockKeepTempFiles = mempty, --TODO: from build settings-      haddockVerbosity     = toFlag verbosity+      haddockVerbosity     = toFlag verbosity,+      haddockCabalFilePath = mempty     }  {-@@ -3323,6 +3517,7 @@       pkgHashProfExeDetail       = elabProfExeDetail,       pkgHashCoverage            = elabCoverage,       pkgHashOptimization        = elabOptimization,+      pkgHashSplitSections       = elabSplitSections,       pkgHashSplitObjs           = elabSplitObjs,       pkgHashStripLibs           = elabStripLibs,       pkgHashStripExes           = elabStripExes,@@ -3354,3 +3549,39 @@      --TODO: decide what to do if we encounter broken installed packages,     -- since overwriting is never safe.+++-- Path construction+------++-- | The path to the directory that contains a specific executable.+-- NB: For inplace NOT InstallPaths.bindir installDirs; for an+-- inplace build those values are utter nonsense.  So we+-- have to guess where the directory is going to be.+-- Fortunately this is "stable" part of Cabal API.+-- But the way we get the build directory is A HORRIBLE+-- HACK.+binDirectoryFor+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedConfiguredPackage+  -> FilePath+  -> FilePath+binDirectoryFor layout config package exe = case elabBuildStyle package of+  BuildAndInstall -> installedBinDirectory package+  BuildInplaceOnly -> inplaceBinRoot layout config package </> exe++-- package has been built and installed.+installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath+installedBinDirectory = InstallDirs.bindir . elabInstallDirs++-- | The path to the @build@ directory for an inplace build.+inplaceBinRoot+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedConfiguredPackage+  -> FilePath+inplaceBinRoot layout config package+  =  distBuildDirectory layout (elabDistDirParams config package)+ </> "build"+

Distribution/Client/ProjectPlanning/Types.hs view

@@ -23,6 +23,7 @@     elabPkgConfigDependencies,     elabInplaceDependencyBuildCacheFiles,     elabRequiresRegistration,+    dataDirsEnvironmentForPlan,      elabPlanPackageName,     elabConfiguredName,@@ -42,6 +43,7 @@     ComponentTarget(..),     showComponentTarget,     showTestComponentTarget,+    showBenchComponentTarget,     SubComponentTarget(..),      isTestComponentTarget,@@ -68,18 +70,21 @@ import           Distribution.Verbosity import           Distribution.Text import           Distribution.Types.ComponentRequestedSpec+import           Distribution.Types.PackageDescription (PackageDescription(..)) import           Distribution.Package                    hiding (InstalledPackageId, installedPackageId) import           Distribution.System import qualified Distribution.PackageDescription as Cabal import           Distribution.InstalledPackageInfo (InstalledPackageInfo) import           Distribution.Simple.Compiler+import           Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import qualified Distribution.Simple.BuildTarget as Cabal import           Distribution.Simple.Program.Db import           Distribution.ModuleName (ModuleName) import           Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.InstallDirs as InstallDirs import           Distribution.Simple.InstallDirs (PathTemplate)+import           Distribution.Simple.Setup (HaddockTarget) import           Distribution.Version  import qualified Distribution.Solver.Types.ComponentDeps as CD@@ -89,6 +94,7 @@ import           Distribution.Simple.Utils (ordNub)  import           Data.Map (Map)+import           Data.Maybe (catMaybes) import           Data.Set (Set) import qualified Data.ByteString.Lazy as LBS import           Distribution.Compat.Binary@@ -96,7 +102,7 @@ import qualified Data.Monoid as Mon import           Data.Typeable import           Control.Monad-+import           System.FilePath ((</>))   -- | The combination of an elaborated install plan plus a@@ -229,6 +235,7 @@        -- TODO: make per-component variants of these flags        elabVanillaLib           :: Bool,        elabSharedLib            :: Bool,+       elabStaticLib            :: Bool,        elabDynExe               :: Bool,        elabGHCiLib              :: Bool,        elabProfLib              :: Bool,@@ -238,6 +245,7 @@        elabCoverage             :: Bool,        elabOptimization         :: OptimisationLevel,        elabSplitObjs            :: Bool,+       elabSplitSections        :: Bool,        elabStripLibs            :: Bool,        elabStripExes            :: Bool,        elabDebugInfo            :: DebugInfoLevel,@@ -258,12 +266,13 @@        elabHaddockHtml           :: Bool,        elabHaddockHtmlLocation   :: Maybe String,        elabHaddockForeignLibs    :: Bool,+       elabHaddockForHackage     :: HaddockTarget,        elabHaddockExecutables    :: Bool,        elabHaddockTestSuites     :: Bool,        elabHaddockBenchmarks     :: Bool,        elabHaddockInternal       :: Bool,        elabHaddockCss            :: Maybe FilePath,-       elabHaddockHscolour       :: Bool,+       elabHaddockLinkedSource   :: Bool,        elabHaddockHscolourCss    :: Maybe FilePath,        elabHaddockContents       :: Maybe PathTemplate, @@ -282,6 +291,7 @@        -- Build time related:        elabBuildTargets          :: [ComponentTarget],        elabTestTargets           :: [ComponentTarget],+       elabBenchTargets          :: [ComponentTarget],        elabReplTarget            :: Maybe ComponentTarget,        elabBuildHaddocks         :: Bool, @@ -331,6 +341,38 @@     is_lib (CSubLibName _) = True     is_lib _ = False +-- | Construct the environment needed for the data files to work.+-- This consists of a separate @*_datadir@ variable for each+-- inplace package in the plan.+dataDirsEnvironmentForPlan :: ElaboratedInstallPlan+                           -> [(String, Maybe FilePath)]+dataDirsEnvironmentForPlan = catMaybes+                           . fmap (InstallPlan.foldPlanPackage+                               (const Nothing)+                               dataDirEnvVarForPackage)+                           . InstallPlan.toList++-- | Construct an environment variable that points+-- the package's datadir to its correct location.+-- This might be:+-- * 'Just' the package's source directory plus the data subdirectory+--   for inplace packages.+-- * 'Nothing' for packages installed in the store (the path was+--   already included in the package at install/build time).+-- * The other cases are not handled yet. See below.+dataDirEnvVarForPackage :: ElaboratedConfiguredPackage+                        -> Maybe (String, Maybe FilePath)+dataDirEnvVarForPackage pkg =+  case (elabBuildStyle pkg, elabPkgSourceLocation pkg)+  of (BuildAndInstall, _) -> Nothing+     (BuildInplaceOnly, LocalUnpackedPackage path) -> Just+       (pkgPathEnvVar (elabPkgDescription pkg) "datadir",+        Just $ path </> dataDir (elabPkgDescription pkg))+     -- TODO: handle the other cases for PackageLocation.+     -- We will only need this when we add support for+     -- remote/local tarballs.+     (BuildInplaceOnly, _) -> Nothing+ instance Package ElaboratedConfiguredPackage where   packageId = elabPkgSourceId @@ -411,7 +453,8 @@ elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderLibDependencies elab =     case elabPkgOrComp elab of-        ElabPackage _      -> map (newSimpleUnitId . confInstId) (elabLibDependencies elab)+        ElabPackage pkg    -> map (newSimpleUnitId . confInstId) $+                              ordNub $ CD.flatDeps (pkgLibDependencies pkg)         ElabComponent comp -> compOrderLibDependencies comp  -- | The library dependencies (i.e., the libraries we depend on, NOT@@ -655,6 +698,10 @@ isTestComponentTarget :: ComponentTarget -> Bool isTestComponentTarget (ComponentTarget (CTestName _) _) = True isTestComponentTarget _                                 = False++showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String+showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ display n+showBenchComponentTarget _ _ = Nothing  --------------------------- -- Setup.hs script policy

Distribution/Client/Reconfigure.hs view

@@ -1,11 +1,9 @@ module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where -import Control.Monad ( unless, when )-import Data.Maybe ( isJust )-import Data.Monoid hiding ( (<>) )-import System.Directory ( doesFileExist )+import Distribution.Client.Compat.Prelude -import Distribution.Compat.Semigroup+import Data.Monoid ( Any(..) )+import System.Directory ( doesFileExist )  import Distribution.Verbosity @@ -31,9 +29,9 @@ -- | @Check@ represents a function to check some condition on type @a@. The -- returned 'Any' is 'True' if any part of the condition failed. newtype Check a = Check {-  runCheck :: Any  -- ^ Did any previous check fail?-           -> a  -- ^ value returned by previous checks-           -> IO (Any, a)  -- ^ Did this check fail? What value is returned?+  runCheck :: Any          -- Did any previous check fail?+           -> a            -- value returned by previous checks+           -> IO (Any, a)  -- Did this check fail? What value is returned? }  instance Semigroup (Check a) where

Distribution/Client/Sandbox.hs view

@@ -80,11 +80,7 @@                                               , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration                                               ( flattenPackageDescription )-#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse  ( readGenericPackageDescription )-#endif import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure          ( configCompilerAuxEx                                               , getPackageDBContents

Distribution/Client/Sandbox/Index.hs view

@@ -39,11 +39,12 @@ import Distribution.Verbosity    ( Verbosity )  import qualified Data.ByteString.Lazy as BS+import Control.DeepSeq           ( NFData(rnf) ) import Control.Exception         ( evaluate, throw, Exception ) import Control.Monad             ( liftM, unless ) import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell) import Data.List                 ( (\\), intersect, nub, find )-import Data.Maybe                ( catMaybes, fromMaybe )+import Data.Maybe                ( catMaybes ) import Data.Either               (partitionEithers) import System.Directory          ( createDirectoryIfMissing,                                    doesDirectoryExist, doesFileExist,@@ -57,6 +58,9 @@   buildTreePath     :: !FilePath   } +instance NFData BuildTreeRef where+  rnf (BuildTreeRef _ fp) = rnf fp+ defaultIndexFileName :: FilePath defaultIndexFileName = "00-index.tar" @@ -224,7 +228,7 @@                                        then tell [pth] >> return False                                        else return True -      convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict+      convertWith dict pth = maybe pth fst $ find ((==pth) . snd) dict  -- | A build tree ref can become ignored if the user later adds a build tree ref -- with the same package ID. We display ignored build tree refs when the user

Distribution/Client/Sandbox/PackageEnvironment.hs view

@@ -60,7 +60,7 @@                                        , syntaxError, warning ) import Distribution.System             ( Platform ) import Distribution.Verbosity          ( Verbosity, normal )-import Control.Monad                   ( foldM, liftM2, when, unless )+import Control.Monad                   ( foldM, liftM2, unless ) import Data.List                       ( partition, sortBy ) import Data.Maybe                      ( isJust ) import Data.Ord                        ( comparing )@@ -297,7 +297,7 @@         return mempty   where     processConfigParse path (ParseOk warns parseResult) = do-      when (not $ null warns) $ warn verbosity $+      unless (null warns) $ warn verbosity $         unlines (map (showPWarning path) warns)       return parseResult     processConfigParse path (ParseFailed err) = do@@ -322,7 +322,7 @@     Nothing -> die' verbosity $       "The package environment file '" ++ path ++ "' doesn't exist"     Just (ParseOk warns parseResult) -> do-      when (not $ null warns) $ warn verbosity $+      unless (null warns) $ warn verbosity $         unlines (map (showPWarning path) warns)       return parseResult     Just (ParseFailed err) -> do

Distribution/Client/Security/DNS.hs view

@@ -1,17 +1,23 @@+{-# LANGUAGE CPP #-}+ module Distribution.Client.Security.DNS     ( queryBootstrapMirrors     ) where  import Prelude () import Distribution.Client.Compat.Prelude-+import Network.URI (URI(..), URIAuth(..), parseURI)+import Distribution.Verbosity import Control.Monad import Control.DeepSeq (force) import Control.Exception (SomeException, evaluate, try)-import Network.URI (URI(..), URIAuth(..), parseURI)- import Distribution.Simple.Utils-import Distribution.Verbosity+import Distribution.Compat.Exception (displayException)++#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)+import Network.DNS (queryTXT, Name(..), CharStr(..))+import qualified Data.ByteString.Char8 as BS.Char8+#else import Distribution.Simple.Program.Db          ( emptyProgramDb, addKnownProgram          , configureAllKnownPrograms, lookupProgram )@@ -19,7 +25,7 @@          ( simpleProgram          , programInvocation          , getProgramInvocationOutput )-import Distribution.Compat.Exception (displayException)+#endif  -- | Try to lookup RFC1464-encoded mirror urls for a Hackage -- repository url by performing a DNS TXT lookup on the@@ -42,8 +48,48 @@ -- constitute a significant new attack vector anyway. -- queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]++#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)+-- use @resolv@ package for performing DNS queries queryBootstrapMirrors verbosity repoUri   | Just auth <- uriAuthority repoUri = do+         let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth))++         mirrors' <- try $ do+                  txts <- queryTXT mirrorsDnsName+                  evaluate (force $ extractMirrors (map snd txts))++         mirrors <- case mirrors' of+             Left e -> do+                 warn verbosity ("Caught exception during _mirrors lookup:"+++                                 displayException (e :: SomeException))+                 return []+             Right v -> return v++         if null mirrors+         then warn verbosity ("No mirrors found for " ++ show repoUri)+         else do info verbosity ("located " ++ show (length mirrors) +++                                 " mirrors for " ++ show repoUri ++ " :")+                 forM_ mirrors $ \url -> info verbosity ("- " ++ show url)++         return mirrors++  | otherwise = return []++-- | Extract list of mirrors from 'queryTXT' result+extractMirrors :: [[CharStr]] -> [URI]+extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals+  where+    vals = [ (kn,v) | CharStr e <- concat txtChunks+                    , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)]+                    , Just kn <- [isUrlBase k]+                    ]++----------------------------------------------------------------------------+#else /* !defined(MIN_VERSION_resolv) */+-- use external method via @nslookup@+queryBootstrapMirrors verbosity repoUri+  | Just auth <- uriAuthority repoUri = do         progdb <- configureAllKnownPrograms verbosity $                   addKnownProgram nslookupProg emptyProgramDb @@ -90,13 +136,6 @@                     , Just kn <- [isUrlBase k]                     ] -    isUrlBase :: String -> Maybe Int-    isUrlBase s-      | isSuffixOf ".urlbase" s, not (null ns), all isDigit ns = readMaybe ns-      | otherwise = Nothing-      where-        ns = take (length s - 8) s- -- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly parseNsLookupTxt :: String -> Maybe [(String,[String])] parseNsLookupTxt = go0 [] []@@ -127,6 +166,17 @@     qstr acc ('"':cs) = Just (reverse acc, cs)     qstr acc (c:cs)   = qstr (c:acc) cs     qstr _   []       = Nothing++#endif+----------------------------------------------------------------------------++-- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data+isUrlBase :: String -> Maybe Int+isUrlBase s+  | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns+  | otherwise = Nothing+  where+    ns = take (length s - 8) s  -- | Split a TXT string into key and value according to RFC1464. -- Returns 'Nothing' if parsing fails.

Distribution/Client/Setup.hs view

@@ -26,7 +26,7 @@     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , defaultSolver, defaultMaxBackjumps     , listCommand, ListFlags(..)-    , updateCommand+    , updateCommand, UpdateFlags(..), defaultUpdateFlags     , upgradeCommand     , uninstallCommand     , infoCommand, InfoFlags(..)@@ -45,11 +45,10 @@     , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)     , actAsSetupCommand, ActAsSetupFlags(..)     , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)-    , execCommand, ExecFlags(..)+    , execCommand, ExecFlags(..), defaultExecFlags     , userConfigCommand, UserConfigFlags(..)     , manpageCommand -    , applyFlagDefaults     , parsePackageArgs     --TODO: stop exporting these:     , showRepo@@ -61,13 +60,15 @@ import Distribution.Client.Compat.Prelude hiding (get)  import Distribution.Client.Types-         ( Username(..), Password(..), RemoteRepo(..) )+         ( Username(..), Password(..), RemoteRepo(..)+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)+         ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types          ( PreSolver(..) ) import Distribution.Client.IndexUtils.Timestamp-         ( IndexState )+         ( IndexState(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets@@ -114,7 +115,7 @@ import Distribution.ParseUtils          ( readPToMaybe ) import Distribution.Verbosity-         ( Verbosity, lessVerbose, normal, verboseNoFlags )+         ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) import Distribution.Simple.Utils          ( wrapText, wrapLine ) import Distribution.Client.GlobalFlags@@ -129,15 +130,6 @@ import Network.URI          ( parseAbsoluteURI, uriToString ) -applyFlagDefaults :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-                  -> (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-applyFlagDefaults (configFlags, configExFlags, installFlags, haddockFlags) =-  ( commandDefaultFlags configureCommand <> configFlags-  , defaultConfigExFlags <> configExFlags-  , defaultInstallFlags <> installFlags-  , Cabal.defaultHaddockFlags <> haddockFlags-  )- globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI {     commandName         = "",@@ -408,7 +400,7 @@ filterConfigureFlags flags cabalLibVersion   -- NB: we expect the latest version to be the most common case,   -- so test it first.-  | cabalLibVersion >= mkVersion [1,25,0] = flags_latest+  | cabalLibVersion >= mkVersion [2,1,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@@ -425,22 +417,27 @@   | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0   | 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   where     flags_latest = flags        {       -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.-      configConstraints = [],-      -- Passing '--allow-{older,newer}' to Setup.hs is unnecessary, we use-      -- '--exact-configuration' instead.-      configAllowOlder  = Just (Cabal.AllowOlder Cabal.RelaxDepsNone),-      configAllowNewer  = Just (Cabal.AllowNewer Cabal.RelaxDepsNone)+      configConstraints = []       } -    flags_1_25_0 = flags_latest {+    flags_2_1_0 = flags_latest {+      -- 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+      , configStaticLib   = NoFlag+      , configSplitSections = NoFlag+      }++    flags_1_25_0 = flags_2_1_0 {       -- Cabal < 1.25.0 doesn't know about --dynlibdir.       configInstallDirs = configInstallDirs_1_25_0,       -- Cabal < 1.25 doesn't have extended verbosity syntax-      configVerbosity   = fmap verboseNoFlags (configVerbosity flags_latest),+      configVerbosity   = fmap verboseNoFlags (configVerbosity flags_2_1_0),       -- Cabal < 1.25 doesn't support --deterministic       configDeterministic = mempty       }@@ -521,7 +518,9 @@     configCabalVersion :: Flag Version,     configExConstraints:: [(UserConstraint, ConstraintSource)],     configPreferences  :: [Dependency],-    configSolver       :: Flag PreSolver+    configSolver       :: Flag PreSolver,+    configAllowNewer   :: Maybe AllowNewer,+    configAllowOlder   :: Maybe AllowOlder   }   deriving (Eq, Generic) @@ -570,8 +569,35 @@    , optionSolver configSolver (\v flags -> flags { configSolver = v }) +  , option [] ["allow-older"]+    ("Ignore lower bounds in all dependencies or DEPS")+    (fmap unAllowOlder . configAllowOlder)+    (\v flags -> flags { configAllowOlder = fmap AllowOlder v})+    (optArg "DEPS"+     (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (Just RelaxDepsAll) relaxDepsPrinter)++  , option [] ["allow-newer"]+    ("Ignore upper bounds in all dependencies or DEPS")+    (fmap unAllowNewer . configAllowNewer)+    (\v flags -> flags { configAllowNewer = fmap AllowNewer v})+    (optArg "DEPS"+     (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (Just RelaxDepsAll) relaxDepsPrinter)+   ] ++relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps)+relaxDepsParser =+  (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',')++relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]+relaxDepsPrinter Nothing                     = []+relaxDepsPrinter (Just RelaxDepsAll)         = [Nothing]+relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs++ instance Monoid ConfigExFlags where   mempty = gmempty   mappend = (<>)@@ -729,6 +755,8 @@       fetchShadowPkgs       :: Flag ShadowPkgs,       fetchStrongFlags      :: Flag StrongFlags,       fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls,+      fetchTests            :: Flag Bool,+      fetchBenchmarks       :: Flag Bool,       fetchVerbosity :: Flag Verbosity     } @@ -745,6 +773,8 @@     fetchShadowPkgs       = Flag (ShadowPkgs False),     fetchStrongFlags      = Flag (StrongFlags False),     fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False),+    fetchTests            = toFlag False,+    fetchBenchmarks       = toFlag False,     fetchVerbosity = toFlag normal    } @@ -782,6 +812,16 @@            fetchDryRun (\v flags -> flags { fetchDryRun = v })            trueArg +      , option "" ["tests"]+         "dependency checking and compilation for test suites listed in the package description file."+         fetchTests (\v flags -> flags { fetchTests = v })+         (boolOpt [] [])++      , option "" ["benchmarks"]+         "dependency checking and compilation for benchmarks listed in the package description file."+         fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v })+         (boolOpt [] [])+        ] ++         optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :@@ -1014,10 +1054,23 @@       (Parse.sepBy1 parse (Parse.char ','))  -- --------------------------------------------------------------- * Other commands+-- * Update command -- ------------------------------------------------------------ -updateCommand  :: CommandUI (Flag Verbosity)+data UpdateFlags+    = UpdateFlags {+        updateVerbosity  :: Flag Verbosity,+        updateIndexState :: Flag IndexState+    } deriving Generic++defaultUpdateFlags :: UpdateFlags+defaultUpdateFlags+    = UpdateFlags {+        updateVerbosity  = toFlag normal,+        updateIndexState = toFlag IndexStateHead+    }++updateCommand  :: CommandUI UpdateFlags updateCommand = CommandUI {     commandName         = "update",     commandSynopsis     = "Updates list of known packages.",@@ -1028,10 +1081,27 @@                                ,"remote-repo-cache"                                ,"local-repo"],     commandUsage        = usageFlags "update",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]+    commandDefaultFlags = defaultUpdateFlags,+    commandOptions      = \_ -> [+        optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }),+        option [] ["index-state"]+          ("Update the source package index to its state as it existed at a previous time. " +++           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " +++           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")+          updateIndexState (\v flags -> flags { updateIndexState = v })+          (reqArg "STATE" (readP_to_E (const $ "index-state must be a  " +++                                       "unix-timestamps (e.g. '@1474732068'), " +++                                       "a ISO8601 UTC timestamp " +++                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))+    ]   } +-- ------------------------------------------------------------+-- * Other commands+-- ------------------------------------------------------------+ upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) upgradeCommand = configureCommand {     commandName         = "upgrade",@@ -1406,6 +1476,7 @@ data InstallFlags = InstallFlags {     installDocumentation    :: Flag Bool,     installHaddockIndex     :: Flag PathTemplate,+    installDest             :: Flag Cabal.CopyDest,     installDryRun           :: Flag Bool,     installMaxBackjumps     :: Flag Int,     installReorderGoals     :: Flag ReorderGoals,@@ -1450,6 +1521,7 @@ defaultInstallFlags = InstallFlags {     installDocumentation   = Flag False,     installHaddockIndex    = Flag docIndexFile,+    installDest            = Flag Cabal.NoCopyDest,     installDryRun          = Flag False,     installMaxBackjumps    = Flag defaultMaxBackjumps,     installReorderGoals    = Flag (ReorderGoals False),@@ -1548,12 +1620,20 @@   commandDefaultFlags = (mempty, mempty, mempty, mempty),   commandOptions      = \showOrParseArgs ->        liftOptions get1 set1+       -- Note: [Hidden Flags]+       -- hide "constraint", "dependency", and+       -- "exact-configuration" from the configure options.        (filter ((`notElem` ["constraint", "dependency"                            , "exact-configuration"])                 . optionName) $                               configureOptions   showOrParseArgs)     ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)-    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)+    ++ liftOptions get3 set3+       -- hide "target-package-db" flag from the+       -- install options.+       (filter ((`notElem` ["target-package-db"])+                . optionName) $+                              installOptions     showOrParseArgs)     ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)   }   where@@ -1572,7 +1652,7 @@     , name `elem` ["hoogle", "html", "html-location"                   ,"executables", "tests", "benchmarks", "all", "internal", "css"                   ,"hyperlink-source", "hscolour-css"-                  ,"contents-location"]+                  ,"contents-location", "for-hackage"]     ]   where     fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a@@ -1598,6 +1678,12 @@           "Do not install anything, only print what would be installed."           installDryRun (\v flags -> flags { installDryRun = v })           trueArg++      , option "" ["target-package-db"]+         "package database to install into. Required when using ${pkgroot} prefix."+         installDest (\v flags -> flags { installDest = v })+         (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb))+                            (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> []))       ] ++        optionSolverFlags showOrParseArgs@@ -1946,6 +2032,12 @@         (\v flags -> flags { IT.packageType = v })         (noArg (Flag IT.Executable)) +        , option [] ["is-libandexe"]+        "Build a library and an executable."+        IT.packageType+        (\v flags -> flags { IT.packageType = v })+        (noArg (Flag IT.LibraryAndExecutable))+       , option [] ["main-is"]         "Specify the main module."         IT.mainIs@@ -2317,14 +2409,16 @@ -- ------------------------------------------------------------  data UserConfigFlags = UserConfigFlags {-  userConfigVerbosity :: Flag Verbosity,-  userConfigForce     :: Flag Bool-} deriving Generic+  userConfigVerbosity   :: Flag Verbosity,+  userConfigForce       :: Flag Bool,+  userConfigAppendLines :: Flag [String]+  } deriving Generic  instance Monoid UserConfigFlags where   mempty = UserConfigFlags {-    userConfigVerbosity = toFlag normal,-    userConfigForce     = toFlag False+    userConfigVerbosity   = toFlag normal,+    userConfigForce       = toFlag False,+    userConfigAppendLines = toFlag []     }   mappend = (<>) @@ -2360,6 +2454,12 @@      "Overwrite the config file if it already exists."      userConfigForce (\v flags -> flags { userConfigForce = v })      trueArg+ , option ['a'] ["augment"]+     "Additional setting to augment the config file (replacing a previous setting if it existed)."+     userConfigAppendLines (\v flags -> flags+                               {userConfigAppendLines =+                                   Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)})+     (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe))    ]   } @@ -2399,7 +2499,7 @@                   -> (flags -> Flag StrongFlags)      -> (Flag StrongFlags      -> flags -> flags)                   -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags)                   -> [OptionField flags]-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc getig setig                   getsip setsip getstrfl setstrfl getib setib =   [ 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.")@@ -2416,14 +2516,11 @@       (fmap asBool . getcc)       (setcc . fmap CountConflicts)       (yesNoOpt showOrParseArgs)-  -- TODO: Disabled for now because it may not be necessary-{-   , 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)       (setig . fmap IndependentGoals)       (yesNoOpt showOrParseArgs)--}   , option [] ["shadow-installed-packages"]       "If multiple package instances of the same version are installed, treat all but one as shadowed."       (fmap asBool . getsip)

Distribution/Client/SetupWrapper.hs view

@@ -38,15 +38,10 @@ import Distribution.Types.Dependency import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)-         , PackageDescription(..), specVersion-         , BuildType(..), knownBuildTypes, defaultRenaming )-#ifdef CABAL_PARSEC+         , PackageDescription(..), specVersion, buildType+         , BuildType(..), defaultRenaming ) import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse-         ( readGenericPackageDescription )-#endif import Distribution.Simple.Configure          ( configCompilerEx ) import Distribution.Compiler@@ -91,7 +86,7 @@          , copyFileVerbose, rewriteFileEx ) import Distribution.Client.Utils          ( inDir, tryCanonicalizePath, withExtraPathEnv-         , existsAndIsMoreRecentThan, moreRecentFile, withEnv+         , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides #ifdef mingw32_HOST_OS          , canonicalizePathNoThrow #endif@@ -147,7 +142,7 @@                  | ExternalMethod FilePath                    -- ^ run Cabal commands through a custom \"Setup\" executable ---TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two+-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two -- parts: one that has no policy and just does as it's told with all the -- explicit options, and an optional initial part that applies certain -- policies (like if we should add the Cabal lib as a dep, and if so which@@ -190,6 +185,11 @@     useWorkingDir            :: Maybe FilePath,     -- | Extra things to add to PATH when invoking the setup script.     useExtraPathEnv          :: [FilePath],+    -- | Extra environment variables paired with overrides, where+    --+    -- * @'Just' v@ means \"set the environment variable's value to @v@\".+    -- * 'Nothing' means \"unset the environment variable\".+    useExtraEnvOverrides     :: [(String, Maybe FilePath)],     forceExternalSetupMethod :: Bool,      -- | List of dependencies to use when building Setup.hs.@@ -264,6 +264,7 @@     useLoggingHandle         = Nothing,     useWorkingDir            = Nothing,     useExtraPathEnv          = [],+    useExtraEnvOverrides     = [],     useWin32CleanHack        = False,     forceExternalSetupMethod = False,     setupCacheLock           = Nothing,@@ -298,8 +299,7 @@                                           (useCabalVersion options)                                           (orLaterVersion (specVersion pkg))                     }-      buildType'  = fromMaybe Custom (buildType pkg)-  checkBuildType buildType'+      buildType'  = buildType pkg   (version, method, options'') <-     getSetupMethod verbosity options' pkg buildType'   return Setup { setupMethod = method@@ -313,12 +313,6 @@          >>= readGenericPackageDescription verbosity          >>= return . packageDescription -    checkBuildType (UnknownBuildType name) =-      die' verbosity $ "The build-type '" ++ name ++ "' is not known. Use one of: "-         ++ intercalate ", " (map display knownBuildTypes) ++ "."-    checkBuildType _ = return ()-- -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script.@@ -365,7 +359,7 @@ -- verbosity applies to ALL commands. verbosityHack :: Version -> [String] -> [String] verbosityHack ver args0-    | ver >= mkVersion [1,25] = args0+    | ver >= mkVersion [2,1]  = args0     | otherwise = go args0   where     go (('-':'v':rest) : args)@@ -380,11 +374,15 @@      munch rest =         case runReadE flagToVerbosity rest of-            Right v | verboseHasFlags v+            Right v+              | ver < mkVersion [2,0], verboseHasFlags v               -- We could preserve the prefix, but since we're assuming               -- it's Cabal's verbosity flag, we can assume that               -- any format is OK               -> Just (showForCabal (verboseNoFlags v))+              | ver < mkVersion [2,1], isVerboseTimestamp v+              -- +timestamp wasn't yet available in Cabal-2.0.0+              -> Just (showForCabal (verboseNoTimestamp v))             _ -> Nothing  -- | Run a command through a configured 'Setup'.@@ -422,7 +420,8 @@   inDir (useWorkingDir options) $ do     withEnv "HASKELL_DIST_DIR" (useDistPref options) $       withExtraPathEnv (useExtraPathEnv options) $-        buildTypeAction bt args+        withEnvOverrides (useExtraEnvOverrides options) $+          buildTypeAction bt args  buildTypeAction :: BuildType -> ([String] -> IO ()) buildTypeAction Simple    = Simple.defaultMainArgs@@ -430,7 +429,6 @@                               Simple.autoconfUserHooks buildTypeAction Make      = Make.defaultMainArgs buildTypeAction Custom               = error "buildTypeAction Custom"-buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"   -- | @runProcess'@ is a version of @runProcess@ where we have@@ -453,9 +451,7 @@                      , Process.std_in  = mbToStd mb_stdin                      , Process.std_out = mbToStd mb_stdout                      , Process.std_err = mbToStd mb_stderr-#if MIN_VERSION_process(1,2,0)                      , Process.delegate_ctlc = _delegate-#endif                      }   return ph   where@@ -483,8 +479,10 @@   searchpath <- programSearchPathAsPATHVar                 (map ProgramSearchPathDir (useExtraPathEnv options) ++                  getProgramSearchPath (useProgramDb options))-  env       <- getEffectiveEnvironment [("PATH", Just searchpath)-                                        ,("HASKELL_DIST_DIR", Just (useDistPref options))]+  env       <- getEffectiveEnvironment $+                 [ ("PATH", Just searchpath)+                 , ("HASKELL_DIST_DIR", Just (useDistPref options))+                 ] ++ useExtraEnvOverrides options   process <- runProcess' path args              (useWorkingDir options) env Nothing              (useLoggingHandle options) (useLoggingHandle options)@@ -516,9 +514,12 @@       searchpath <- programSearchPathAsPATHVar                     (map ProgramSearchPathDir (useExtraPathEnv options) ++                       getProgramSearchPath (useProgramDb options))-      env        <- getEffectiveEnvironment [("PATH", Just searchpath)-                                            ,("HASKELL_DIST_DIR", Just (useDistPref options))]+      env        <- getEffectiveEnvironment $+                      [ ("PATH", Just searchpath)+                      , ("HASKELL_DIST_DIR", Just (useDistPref options))+                      ] ++ useExtraEnvOverrides options +      debug verbosity $ "Setup arguments: "++unwords args       process <- runProcess' path' args                   (useWorkingDir options) env Nothing                   (useLoggingHandle options) (useLoggingHandle options)@@ -702,8 +703,7 @@                    then "autoconfUserHooks\n"                    else "defaultUserHooks\n"     Make      -> "import Distribution.Make; main = defaultMain\n"-    Custom             -> error "buildTypeScript Custom"-    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"+    Custom    -> error "buildTypeScript Custom"    installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb                         -> IO (Version, Maybe InstalledPackageId@@ -788,8 +788,8 @@         buildTypeString       = show bt         cabalVersionString    = "Cabal-" ++ (display cabalLibVersion)         compilerVersionString = display $-                                fromMaybe buildCompilerId-                                (fmap compilerId . useCompiler $ options')+                                maybe buildCompilerId compilerId+                                  $ useCompiler options'         platformString        = display platform    -- | Look up the setup executable in the cache; update the cache if the setup@@ -823,8 +823,7 @@               cachedSetupProgFile     return cachedSetupProgFile       where-        criticalSection'      = fromMaybe id-                                (fmap criticalSection $ setupCacheLock options')+        criticalSection'      = maybe id criticalSection $ setupCacheLock options'    -- | If the Setup.hs is out of date wrt the executable then recompile it.   -- Currently this is GHC/GHCJS only. It should really be generalised.

Distribution/Client/SolverInstallPlan.hs view

@@ -70,7 +70,7 @@ import Data.List          ( intercalate ) import Data.Maybe-         ( fromMaybe, catMaybes )+         ( fromMaybe, mapMaybe ) import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (Graph, IsNode(..)) import qualified Data.Graph as OldGraph@@ -226,10 +226,9 @@ problems indepGoals index =       [ PackageMissingDeps pkg-       (catMaybes-        (map+       (mapMaybe          (fmap packageId . flip Graph.lookup index)-         missingDeps))+         missingDeps)      | (pkg, missingDeps) <- Graph.broken index ]    ++ [ PackageCycle cycleGroup

+ Distribution/Client/SourceRepoParse.hs view

@@ -0,0 +1,22 @@+module Distribution.Client.SourceRepoParse where++import Distribution.Client.Compat.Prelude+import Prelude ()++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 (..))++sourceRepoFieldDescrs :: [FieldDescr SourceRepo]+sourceRepoFieldDescrs =+    map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused")+  where+    toDescr (name, pretty, parse) = FieldDescr+        { fieldName = name+        , fieldGet  = pretty+        , fieldSet  = \lineNo str x ->+              either (syntaxError lineNo) return+              $ explicitEitherParsec (parse x) str+        }

Distribution/Client/SrcDist.hs view

@@ -20,13 +20,8 @@          ( PackageDescription ) import Distribution.PackageDescription.Configuration          ( flattenPackageDescription )-#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse-         ( readGenericPackageDescription )-#endif import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, defaultPackageDesc          , warn, die', notice, withTempDirectory )

Distribution/Client/Store.hs view

@@ -39,6 +39,7 @@ import           Data.Set (Set) import qualified Data.Set as Set import           Control.Exception+import           Control.Monad (forM_) import           System.FilePath import           System.Directory import           System.IO@@ -171,7 +172,7 @@               -> StoreDirLayout               -> CompilerId               -> UnitId-              -> (FilePath -> IO FilePath) -- ^ Action to place files.+              -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files.               -> IO ()                     -- ^ Register action, if necessary.               -> IO NewStoreEntryOutcome newStoreEntry verbosity storeDirLayout@StoreDirLayout{..}@@ -182,7 +183,7 @@     withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do        -- Write all store entry files within the temp dir and return the prefix.-      incomingEntryDir <- copyFiles incomingTmpDir+      (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir        -- Take a lock named after the 'UnitId' in question.       withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do@@ -207,6 +208,10 @@              -- Atomically rename the temp dir to the final store entry location.             renameDirectory incomingEntryDir finalEntryDir+            forM_ otherFiles $ \file -> do+              let finalStoreFile = storeDirectory compid </> makeRelative (incomingTmpDir </> (dropDrive (storeDirectory compid))) file+              createDirectoryIfMissing True (takeDirectory finalStoreFile)+              renameFile file finalStoreFile              debug verbosity $               "Installed store entry " ++ display compid </> display unitid

Distribution/Client/TargetSelector.hs view

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards #-}+{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor,+             RecordWildCards, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.TargetSelector@@ -16,6 +17,7 @@     TargetSelector(..),     TargetImplicitCwd(..),     ComponentKind(..),+    ComponentKindFilter,     SubComponentTarget(..),     QualLevel(..),     componentKind,@@ -34,14 +36,16 @@     defaultDirActions,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Package-         ( Package(..), PackageId, PackageIdentifier(..), packageName-         , mkPackageName )-import Distribution.Version-         ( mkVersion )-import Distribution.Types.UnqualComponentName ( unUnqualComponentName )+         ( Package(..), PackageId, PackageName, packageName )+import Distribution.Types.UnqualComponentName+         ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName+         , packageNameToUnqualComponentName ) import Distribution.Client.Types-         ( PackageLocation(..) )+         ( PackageLocation(..), PackageSpecifier(..) )  import Distribution.Verbosity import Distribution.PackageDescription@@ -62,7 +66,7 @@ import Distribution.Types.ForeignLib  import Distribution.Text-         ( display, simpleParse )+         ( Text, display, simpleParse ) import Distribution.Simple.Utils          ( die', lowercase, ordNub ) import Distribution.Client.Utils@@ -73,36 +77,19 @@ import Data.Function          ( on ) import Data.List-         ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy )-import Data.Maybe-         ( maybeToList )+         ( stripPrefix, partition, groupBy ) import Data.Ord          ( comparing )-import Distribution.Compat.Binary (Binary)-import GHC.Generics (Generic)-#if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Lazy   as Map.Lazy import qualified Data.Map.Strict as Map-import Data.Map.Strict (Map)-#else-import qualified Data.Map as Map.Lazy-import qualified Data.Map as Map-import Data.Map (Map)-#endif import qualified Data.Set as Set import Control.Arrow ((&&&)) import Control.Monad-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..), (<$>))-#endif-import Control.Applicative (Alternative(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP          ( (+++), (<++) ) import Distribution.ParseUtils          ( readPToMaybe )-import Data.Char-         ( isSpace, isAlphaNum ) import System.FilePath as FilePath          ( takeExtension, dropExtension          , splitDirectories, joinPath, splitPath )@@ -139,24 +126,42 @@ -- > [ [lib:|exe:] component name ] -- > [ module name | source file ] ---data TargetSelector pkg =+data TargetSelector = -     -- | A package as a whole: the default components for the package or all-     -- components of a particular kind.+     -- | One (or more) packages as a whole, or all the components of a+     -- particular kind within the package(s).      ---     TargetPackage TargetImplicitCwd pkg (Maybe ComponentKindFilter)+     -- These are always packages that are local to the project. In the case+     -- that there is more than one, they all share the same directory location.+     --+     TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) +     -- | A package specified by name. This may refer to @extra-packages@ from+     -- the @cabal.project@ file, or a dependency of a known project package or+     -- could refer to a package from a hackage archive. It needs further+     -- context to resolve to a specific package.+     --+   | TargetPackageNamed PackageName (Maybe ComponentKindFilter)+      -- | All packages, or all components of a particular kind in all packages.      --    | TargetAllPackages (Maybe ComponentKindFilter) -     -- | A specific component in a package.+     -- | A specific component in a package within the project.      ---   | TargetComponent pkg ComponentName SubComponentTarget-  deriving (Eq, Ord, Functor, Show, Generic)+   | TargetComponent PackageId ComponentName SubComponentTarget +     -- | A component in a package, but where it cannot be verified that the+     -- package has such a component, or because the package is itself not+     -- known.+     --+   | TargetComponentUnknown PackageName+                            (Either UnqualComponentName ComponentName)+                            SubComponentTarget+  deriving (Eq, Ord, Show, Generic)+ -- | Does this 'TargetPackage' selector arise from syntax referring to a--- packge in the current directory (e.g. @tests@ or no giving no explicit+-- package in the current directory (e.g. @tests@ or no giving no explicit -- target at all) or does it come from syntax referring to a package name -- or location. --@@ -195,40 +200,26 @@ -- error if any are unrecognised. The possible target selectors are based on -- the available packages (and their locations). ---readTargetSelectors :: [SourcePackage (PackageLocation a)]+readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))]                     -> [String]-                    -> IO (Either [TargetSelectorProblem]-                                  [TargetSelector PackageId])+                    -> IO (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectors = readTargetSelectorsWith defaultDirActions  readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m-                        -> [SourcePackage (PackageLocation a)]+                        -> [PackageSpecifier (SourcePackage (PackageLocation a))]                         -> [String]-                        -> m (Either [TargetSelectorProblem]-                                     [TargetSelector PackageId])+                        -> m (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs =     case parseTargetStrings targetStrs of-      ([], utargets) -> do-        utargets' <- mapM (getTargetStringFileStatus dirActions) utargets-        pkgs'     <- mapM (selectPackageInfo dirActions) pkgs-        cwd       <- getCurrentDirectory-        let (cwdPkg, otherPkgs) = selectCwdPackage cwd pkgs'-        case resolveTargetSelectors cwdPkg otherPkgs utargets' of-          ([], btargets) -> return (Right (map (fmap packageId) btargets))+      ([], usertargets) -> do+        usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets+        knowntargets <- getKnownTargets dirActions pkgs+        case resolveTargetSelectors knowntargets usertargets' of+          ([], btargets) -> return (Right btargets)           (problems, _)  -> return (Left problems)       (strs, _)          -> return (Left (map TargetSelectorUnrecognised strs))-  where-    selectCwdPackage :: FilePath-                     -> [PackageInfo]-                     -> ([PackageInfo], [PackageInfo])-    selectCwdPackage cwd pkgs' =-        let (cwdpkg, others) = partition isPkgDirCwd pkgs'-         in (cwdpkg, others)-      where-        isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) }-          | dir == cwd = True-        isPkgDirCwd _  = False + data DirActions m = DirActions {        doesFileExist       :: FilePath -> m Bool,        doesDirectoryExist  :: FilePath -> m Bool,@@ -350,23 +341,29 @@     components (TargetString5 s1 s2 s3 s4 s5)       = [s1,s2,s3,s4,s5]     components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] -showTargetSelector :: Package p => TargetSelector p -> String+showTargetSelector :: TargetSelector -> String showTargetSelector ts =-  let (t':_) = [ t | ql <- [QL1 .. QLFull]-                   , t  <- renderTargetSelector ql ts ]-   in showTargetString (forgetFileStatus t')+  case [ t | ql <- [QL1 .. QLFull]+           , t  <- renderTargetSelector ql ts ]+  of (t':_) -> showTargetString (forgetFileStatus t')+     [] -> "" -showTargetSelectorKind :: TargetSelector a -> String+showTargetSelectorKind :: TargetSelector -> String showTargetSelectorKind bt = case bt of   TargetPackage TargetExplicitNamed _ Nothing  -> "package"   TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter"   TargetPackage TargetImplicitCwd   _ Nothing  -> "cwd-package"   TargetPackage TargetImplicitCwd   _ (Just _) -> "cwd-package:filter"-  TargetAllPackages Nothing                    -> "all-packages"-  TargetAllPackages (Just _)                   -> "all-packages:filter"-  TargetComponent _ _ WholeComponent           -> "component"-  TargetComponent _ _ ModuleTarget{}           -> "module"-  TargetComponent _ _ FileTarget{}             -> "file"+  TargetPackageNamed                _ Nothing  -> "named-package"+  TargetPackageNamed                _ (Just _) -> "named-package:filter"+  TargetAllPackages Nothing                    -> "package *"+  TargetAllPackages (Just _)                   -> "package *:filter"+  TargetComponent        _ _ WholeComponent    -> "component"+  TargetComponent        _ _ ModuleTarget{}    -> "module"+  TargetComponent        _ _ FileTarget{}      -> "file"+  TargetComponentUnknown _ _ WholeComponent    -> "unknown-component"+  TargetComponentUnknown _ _ ModuleTarget{}    -> "unknown-module"+  TargetComponentUnknown _ _ FileTarget{}      -> "unknown-file"   -- ------------------------------------------------------------@@ -436,43 +433,38 @@ -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. ---resolveTargetSelectors :: [PackageInfo]     -- any pkg in the cur dir-                       -> [PackageInfo]     -- all the other local packages+resolveTargetSelectors :: KnownTargets                        -> [TargetStringFileStatus]                        -> ([TargetSelectorProblem],-                           [TargetSelector PackageInfo])-+                           [TargetSelector]) -- default local dir target if there's no given target:-resolveTargetSelectors [] [] [] =+resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] =     ([TargetSelectorNoTargetsInProject], []) -resolveTargetSelectors [] _opinfo [] =+resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] =     ([TargetSelectorNoTargetsInCwd], []) -resolveTargetSelectors ppinfo _opinfo [] =-    ([], [TargetPackage TargetImplicitCwd (head ppinfo) Nothing])-    --TODO: in future allow multiple packages in the same dir+resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] =+    ([], [TargetPackage TargetImplicitCwd pkgids Nothing])+  where+    pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] -resolveTargetSelectors ppinfo opinfo targetStrs =+resolveTargetSelectors knowntargets targetStrs =     partitionEithers-  . map (resolveTargetSelector ppinfo opinfo)+  . map (resolveTargetSelector knowntargets)   $ targetStrs -resolveTargetSelector :: [PackageInfo] -> [PackageInfo]+resolveTargetSelector :: KnownTargets                       -> TargetStringFileStatus-                      -> Either TargetSelectorProblem-                                (TargetSelector PackageInfo)-resolveTargetSelector ppinfo opinfo targetStrStatus =+                      -> Either TargetSelectorProblem TargetSelector+resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus =     case findMatch (matcher targetStrStatus) of        Unambiguous _         | projectIsEmpty -> Left TargetSelectorNoTargetsInProject -      Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter)-        | null ppinfo -> Left (TargetSelectorNoCurrentPackage targetStr)-        | otherwise   -> Right (TargetPackage TargetImplicitCwd-                                              (head ppinfo) mkfilter)-                       --TODO: in future allow multiple packages in the same dir+      Unambiguous (TargetPackage TargetImplicitCwd [] _)+                         -> Left (TargetSelectorNoCurrentPackage targetStr)        Unambiguous target -> Right target @@ -484,18 +476,15 @@         case disambiguateTargetSelectors                matcher targetStrStatus exactMatch                targets of-          Right targets'   -> Left (TargetSelectorAmbiguous targetStr-                                       (map (fmap (fmap packageId)) targets'))-          Left ((m, ms):_) -> Left (MatchingInternalError targetStr-                                       (fmap packageId m)-                                       (map (fmap (map (fmap packageId))) ms))+          Right targets'   -> Left (TargetSelectorAmbiguous targetStr targets')+          Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms)           Left []          -> internalError "resolveTargetSelector"   where-    matcher = matchTargetSelector ppinfo opinfo+    matcher = matchTargetSelector knowntargets      targetStr = forgetFileStatus targetStrStatus -    projectIsEmpty = null ppinfo && null opinfo+    projectIsEmpty = null knownPackagesAll      classifyMatchErrors errs       | not (null expected)@@ -552,10 +541,10 @@                            [(Maybe (String, String), String, String, [String])]      -- ^ [([in thing], no such thing,  actually got, alternatives)]    | TargetSelectorAmbiguous  TargetString-                              [(TargetString, TargetSelector PackageId)]+                              [(TargetString, TargetSelector)] -   | MatchingInternalError TargetString (TargetSelector PackageId)-                           [(TargetString, [TargetSelector PackageId])]+   | MatchingInternalError TargetString TargetSelector+                           [(TargetString, [TargetSelector])]    | TargetSelectorUnrecognised String      -- ^ Syntax error when trying to parse a target string.    | TargetSelectorNoCurrentPackage TargetString@@ -567,12 +556,11 @@   deriving (Eq, Enum, Show)  disambiguateTargetSelectors-  :: (TargetStringFileStatus -> Match (TargetSelector PackageInfo))-  -> TargetStringFileStatus -> Bool-  -> [TargetSelector PackageInfo]-  -> Either [(TargetSelector PackageInfo,-              [(TargetString, [TargetSelector PackageInfo])])]-            [(TargetString, TargetSelector PackageInfo)]+  :: (TargetStringFileStatus -> Match TargetSelector)+  -> TargetStringFileStatus -> MatchClass+  -> [TargetSelector]+  -> Either [(TargetSelector, [(TargetString, [TargetSelector])])]+            [(TargetString, TargetSelector)] disambiguateTargetSelectors matcher matchInput exactMatch matchResults =     case partitionEithers results of       (errs@(_:_), _) -> Left errs@@ -581,8 +569,7 @@     -- So, here's the strategy. We take the original match results, and make a     -- table of all their renderings at all qualification levels.     -- Note there can be multiple renderings at each qualification level.-    matchResultsRenderings :: [(TargetSelector PackageInfo,-                                [TargetStringFileStatus])]+    matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])]     matchResultsRenderings =       [ (matchResult, matchRenderings)       | matchResult <- matchResults@@ -597,12 +584,12 @@     -- for all of those renderings. So by looking up in this table we can see     -- if we've got an unambiguous match. -    memoisedMatches :: Map TargetStringFileStatus-                           (Match (TargetSelector PackageInfo))+    memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector)     memoisedMatches =         -- avoid recomputing the main one if it was an exact match-        (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults)-                       else id)+        (if exactMatch == Exact+           then Map.insert matchInput (Match Exact 0 matchResults)+           else id)       $ Map.Lazy.fromList           [ (rendering, matcher rendering)           | rendering <- concatMap snd matchResultsRenderings ]@@ -611,9 +598,8 @@     -- possible renderings (in order of qualification level, though remember     -- there can be multiple renderings per level), and find the first one     -- that has an unambiguous match.-    results :: [Either (TargetSelector PackageInfo,-                        [(TargetString, [TargetSelector PackageInfo])])-                       (TargetString, TargetSelector PackageInfo)]+    results :: [Either (TargetSelector, [(TargetString, [TargetSelector])])+                       (TargetString, TargetSelector)]     results =       [ case findUnambiguous originalMatch matchRenderings of           Just unambiguousRendering ->@@ -625,23 +611,24 @@             Left  ( originalMatch                   , [ (forgetFileStatus rendering, matches)                     | rendering <- matchRenderings-                    , let (ExactMatch _ matches) =+                    , let (Match m _ matches) | m /= Inexact =                             memoisedMatches Map.! rendering                     ] )        | (originalMatch, matchRenderings) <- matchResultsRenderings ] -    findUnambiguous :: TargetSelector PackageInfo+    findUnambiguous :: TargetSelector                     -> [TargetStringFileStatus]                     -> Maybe TargetStringFileStatus     findUnambiguous _ []     = Nothing     findUnambiguous t (r:rs) =       case memoisedMatches Map.! r of-        ExactMatch _ [t'] | fmap packageName t == fmap packageName t'-                         -> Just r-        ExactMatch _  _  -> findUnambiguous t rs-        InexactMatch _ _ -> internalError "InexactMatch"-        NoMatch      _ _ -> internalError "NoMatch"+        Match Exact _ [t'] | t == t'+                          -> Just r+        Match Exact   _ _ -> findUnambiguous t rs+        Match Unknown _ _ -> findUnambiguous t rs+        Match Inexact _ _ -> internalError "Match Inexact"+        NoMatch       _ _ -> internalError "NoMatch"  internalError :: String -> a internalError msg =@@ -781,8 +768,8 @@             | AmbiguousAlternatives Syntax Syntax             | ShadowingAlternatives Syntax Syntax -type Matcher  = TargetStringFileStatus -> Match (TargetSelector PackageInfo)-type Renderer = TargetSelector PackageId -> [TargetStringFileStatus]+type Matcher  = TargetStringFileStatus -> Match TargetSelector+type Renderer = TargetSelector -> [TargetStringFileStatus]  foldSyntax :: (a -> a -> a) -> (a -> a -> a)            -> (QualLevel -> Matcher -> Renderer -> a)@@ -798,29 +785,30 @@ -- Top level renderer and matcher -- -renderTargetSelector :: Package p => QualLevel -> TargetSelector p+renderTargetSelector :: QualLevel -> TargetSelector                      -> [TargetStringFileStatus] renderTargetSelector ql ts =     foldSyntax       (++) (++)-      (\ql' _ render -> guard (ql == ql') >> render (fmap packageId ts))+      (\ql' _ render -> guard (ql == ql') >> render ts)       syntax   where-    syntax = syntaxForms [] [] -- don't need pinfo for rendering+    syntax = syntaxForms emptyKnownTargets+                         -- don't need known targets for rendering -matchTargetSelector :: [PackageInfo] -> [PackageInfo]+matchTargetSelector :: KnownTargets                     -> TargetStringFileStatus-                    -> Match (TargetSelector PackageInfo)-matchTargetSelector ppinfo opinfo = \utarget ->-    nubMatchesBy ((==) `on` (fmap packageName)) $+                    -> Match TargetSelector+matchTargetSelector knowntargets = \usertarget ->+    nubMatchesBy (==) $ -    let ql = targetQualLevel utarget in+    let ql = targetQualLevel usertarget in     foldSyntax       (<|>) (<//>)-      (\ql' match _ -> guard (ql == ql') >> match utarget)+      (\ql' match _ -> guard (ql == ql') >> match usertarget)       syntax   where-    syntax = syntaxForms ppinfo opinfo+    syntax = syntaxForms knowntargets      targetQualLevel TargetStringFileStatus1{} = QL1     targetQualLevel TargetStringFileStatus2{} = QL2@@ -836,8 +824,14 @@  -- | All the forms of syntax for 'TargetSelector'. ---syntaxForms :: [PackageInfo] -> [PackageInfo] -> Syntax-syntaxForms ppinfo opinfo =+syntaxForms :: KnownTargets -> Syntax+syntaxForms KnownTargets {+              knownPackagesAll       = pinfo,+              knownPackagesPrimary   = ppinfo,+              knownComponentsAll     = cinfo,+              knownComponentsPrimary = pcinfo,+              knownComponentsOther   = ocinfo+            } =     -- The various forms of syntax here are ambiguous in many cases.     -- Our policy is by default we expose that ambiguity and report     -- ambiguous matches. In certain cases we override the ambiguity@@ -853,7 +847,7 @@       [ shadowingAlternatives           [ ambiguousAlternatives               [ syntaxForm1All-              , syntaxForm1Filter+              , syntaxForm1Filter        ppinfo               , shadowingAlternatives                   [ syntaxForm1Component pcinfo                   , syntaxForm1Package   pinfo@@ -895,7 +889,7 @@          -- fully-qualified forms for all and cwd with filter       , syntaxForm3MetaAllFilter-      , syntaxForm3MetaCwdFilter+      , syntaxForm3MetaCwdFilter ppinfo          -- fully-qualified form for package and package with filter       , syntaxForm3MetaNamespacePackage       pinfo@@ -909,10 +903,6 @@   where     ambiguousAlternatives = foldr1 AmbiguousAlternatives     shadowingAlternatives = foldr1 ShadowingAlternatives-    pinfo  = ppinfo ++ opinfo-    cinfo  = concatMap pinfoComponents pinfo-    pcinfo = concatMap pinfoComponents ppinfo-    ocinfo = concatMap pinfoComponents opinfo   -- | Syntax: "all" to select all packages in the project@@ -933,57 +923,50 @@ -- -- > cabal build tests ---syntaxForm1Filter :: Syntax-syntaxForm1Filter =+syntaxForm1Filter :: [KnownPackage] -> Syntax+syntaxForm1Filter ps =   syntaxForm1 render $ \str1 _fstatus1 -> do     kfilter <- matchComponentKindFilter str1-    return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter))+    return (TargetPackage TargetImplicitCwd pids (Just kfilter))   where+    pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]     render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =       [TargetStringFileStatus1 (dispF kfilter) noFileStatus]     render _ = [] --- Only used for TargetPackage TargetImplicitCwd-dummyPackageInfo :: PackageInfo-dummyPackageInfo =-    PackageInfo {-      pinfoId          = PackageIdentifier-                           (mkPackageName "dummyPackageInfo")-                           (mkVersion []),-      pinfoLocation    = unused,-      pinfoDirectory   = unused,-      pinfoPackageFile = unused,-      pinfoComponents  = unused-    }-  where-    unused = error "dummyPackageInfo"  -- | Syntax: package (name, dir or file) -- -- > cabal build foo -- > cabal build ../bar ../bar/bar.cabal ---syntaxForm1Package :: [PackageInfo] -> Syntax+syntaxForm1Package :: [KnownPackage] -> Syntax syntaxForm1Package pinfo =   syntaxForm1 render $ \str1 fstatus1 -> do     guardPackage            str1 fstatus1     p <- matchPackage pinfo str1 fstatus1-    return (TargetPackage TargetExplicitNamed p Nothing)+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)+      KnownPackageName pn ->+        return (TargetPackageNamed pn Nothing)   where-    render (TargetPackage TargetExplicitNamed p Nothing) =+    render (TargetPackage TargetExplicitNamed [p] Nothing) =       [TargetStringFileStatus1 (dispP p) noFileStatus]+    render (TargetPackageNamed pn Nothing) =+      [TargetStringFileStatus1 (dispPN pn) noFileStatus]     render _ = []  -- | Syntax: component -- -- > cabal build foo ---syntaxForm1Component :: [ComponentInfo] -> Syntax+syntaxForm1Component :: [KnownComponent] -> Syntax syntaxForm1Component cs =   syntaxForm1 render $ \str1 _fstatus1 -> do     guardComponentName str1     c <- matchComponentName cs str1-    return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent)+    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)   where     render (TargetComponent p c WholeComponent) =       [TargetStringFileStatus1 (dispC p c) noFileStatus]@@ -993,13 +976,13 @@ -- -- > cabal build Data.Foo ---syntaxForm1Module :: [ComponentInfo] -> Syntax+syntaxForm1Module :: [KnownComponent] -> Syntax syntaxForm1Module cs =   syntaxForm1 render $  \str1 _fstatus1 -> do     guardModuleName str1     let ms = [ (m,c) | c <- cs, m <- cinfoModules c ]     (m,c) <- matchModuleNameAnd ms str1-    return (TargetComponent (cinfoPackage c) (cinfoName c) (ModuleTarget m))+    return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m))   where     render (TargetComponent _p _c (ModuleTarget m)) =       [TargetStringFileStatus1 (dispM m) noFileStatus]@@ -1009,7 +992,7 @@ -- -- > cabal build Data/Foo.hs bar/Main.hsc ---syntaxForm1File :: [PackageInfo] -> Syntax+syntaxForm1File :: [KnownPackage] -> Syntax syntaxForm1File ps =     -- Note there's a bit of an inconsistency here vs the other syntax forms     -- for files. For the single-part syntax the target has to point to a file@@ -1017,10 +1000,12 @@     -- all the other forms we don't require that.   syntaxForm1 render $ \str1 fstatus1 ->     expecting "file" str1 $ do-    (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile-      return (TargetComponent p (cinfoName c) (FileTarget filepath))+    (pkgfile, ~KnownPackage{pinfoId, pinfoComponents})+      -- always returns the KnownPackage case+      <- matchPackageDirectoryPrefix ps fstatus1+    orNoThingIn "package" (display (packageName pinfoId)) $ do+      (filepath, c) <- matchComponentFile pinfoComponents pkgfile+      return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))   where     render (TargetComponent _p _c (FileTarget f)) =       [TargetStringFileStatus1 f noFileStatus]@@ -1062,32 +1047,44 @@ -- -- > cabal build foo:tests ---syntaxForm2PackageFilter :: [PackageInfo] -> Syntax+syntaxForm2PackageFilter :: [KnownPackage] -> Syntax syntaxForm2PackageFilter ps =   syntaxForm2 render $ \str1 fstatus1 str2 -> do     guardPackage         str1 fstatus1     p <- matchPackage ps str1 fstatus1     kfilter <- matchComponentKindFilter str2-    return (TargetPackage TargetExplicitNamed p (Just kfilter))+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))+      KnownPackageName pn ->+        return (TargetPackageNamed pn (Just kfilter))   where-    render (TargetPackage TargetExplicitNamed p (Just kfilter)) =+    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =       [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)]+    render (TargetPackageNamed pn (Just kfilter)) =+      [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)]     render _ = []  -- | Syntax: pkg : package name -- -- > cabal build pkg:foo ---syntaxForm2NamespacePackage :: [PackageInfo] -> Syntax+syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax syntaxForm2NamespacePackage pinfo =   syntaxForm2 render $ \str1 _fstatus1 str2 -> do     guardNamespacePackage   str1     guardPackageName        str2     p <- matchPackage pinfo str2 noFileStatus-    return (TargetPackage TargetExplicitNamed p Nothing)+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)+      KnownPackageName pn ->+        return (TargetPackageNamed pn Nothing)   where-    render (TargetPackage TargetExplicitNamed p Nothing) =+    render (TargetPackage TargetExplicitNamed [p] Nothing) =       [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)]+    render (TargetPackageNamed pn Nothing) =+      [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)]     render _ = []  -- | Syntax: package : component@@ -1096,36 +1093,43 @@ -- > cabal build ./foo:foo -- > cabal build ./foo.cabal:foo ---syntaxForm2PackageComponent :: [PackageInfo] -> Syntax+syntaxForm2PackageComponent :: [KnownPackage] -> Syntax syntaxForm2PackageComponent ps =   syntaxForm2 render $ \str1 fstatus1 str2 -> do     guardPackage         str1 fstatus1     guardComponentName   str2     p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentName (pinfoComponents p) str2-      return (TargetComponent p (cinfoName c) WholeComponent)-    --TODO: the error here ought to say there's no component by that name in-    -- this package, and name the package+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          c <- matchComponentName pinfoComponents str2+          return (TargetComponent pinfoId (cinfoName c) WholeComponent)+        --TODO: the error here ought to say there's no component by that name in+        -- this package, and name the package+      KnownPackageName pn ->+        let cn = mkUnqualComponentName str2 in+        return (TargetComponentUnknown pn (Left cn) WholeComponent)   where     render (TargetComponent p c WholeComponent) =       [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)]+    render (TargetComponentUnknown pn (Left cn) WholeComponent) =+      [TargetStringFileStatus2 (dispPN pn) noFileStatus (display cn)]     render _ = []  -- | Syntax: namespace : component -- -- > cabal build lib:foo exe:foo ---syntaxForm2KindComponent :: [ComponentInfo] -> Syntax+syntaxForm2KindComponent :: [KnownComponent] -> Syntax syntaxForm2KindComponent cs =   syntaxForm2 render $ \str1 _fstatus1 str2 -> do     ckind <- matchComponentKind str1     guardComponentName str2     c <- matchComponentKindAndName cs ckind str2-    return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent)+    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)   where     render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus2 (dispK c) noFileStatus (dispC p c)]+      [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)]     render _ = []  -- | Syntax: package : module@@ -1134,16 +1138,22 @@ -- > cabal build ./foo:Data.Foo -- > cabal build ./foo.cabal:Data.Foo ---syntaxForm2PackageModule :: [PackageInfo] -> Syntax+syntaxForm2PackageModule :: [KnownPackage] -> Syntax syntaxForm2PackageModule ps =   syntaxForm2 render $ \str1 fstatus1 str2 -> do     guardPackage         str1 fstatus1     guardModuleName      str2     p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ]-      (m,c) <- matchModuleNameAnd ms str2-      return (TargetComponent p (cinfoName c) (ModuleTarget m))+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ]+          (m,c) <- matchModuleNameAnd ms str2+          return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))+      KnownPackageName pn -> do+        m <- matchModuleNameUnknown str2+        -- We assume the primary library component of the package:+        return (TargetComponentUnknown pn (Right CLibName) (ModuleTarget m))   where     render (TargetComponent p _c (ModuleTarget m)) =       [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)]@@ -1153,7 +1163,7 @@ -- -- > cabal build foo:Data.Foo ---syntaxForm2ComponentModule :: [ComponentInfo] -> Syntax+syntaxForm2ComponentModule :: [KnownComponent] -> Syntax syntaxForm2ComponentModule cs =   syntaxForm2 render $ \str1 _fstatus1 str2 -> do     guardComponentName str1@@ -1162,7 +1172,7 @@     orNoThingIn "component" (cinfoStrName c) $ do       let ms = cinfoModules c       m <- matchModuleName ms str2-      return (TargetComponent (cinfoPackage c) (cinfoName c)+      return (TargetComponent (cinfoPackageId c) (cinfoName c)                               (ModuleTarget m))   where     render (TargetComponent p c (ModuleTarget m)) =@@ -1175,14 +1185,20 @@ -- > cabal build ./foo:Data/Foo.hs -- > cabal build ./foo.cabal:Data/Foo.hs ---syntaxForm2PackageFile :: [PackageInfo] -> Syntax+syntaxForm2PackageFile :: [KnownPackage] -> Syntax syntaxForm2PackageFile ps =   syntaxForm2 render $ \str1 fstatus1 str2 -> do     guardPackage         str1 fstatus1     p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      (filepath, c) <- matchComponentFile (pinfoComponents p) str2-      return (TargetComponent p (cinfoName c) (FileTarget filepath))+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          (filepath, c) <- matchComponentFile pinfoComponents str2+          return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))+      KnownPackageName pn ->+        let filepath = str2 in+        -- We assume the primary library component of the package:+        return (TargetComponentUnknown pn (Right CLibName) (FileTarget filepath))   where     render (TargetComponent p _c (FileTarget f)) =       [TargetStringFileStatus2 (dispP p) noFileStatus f]@@ -1192,14 +1208,14 @@ -- -- > cabal build foo:Data/Foo.hs ---syntaxForm2ComponentFile :: [ComponentInfo] -> Syntax+syntaxForm2ComponentFile :: [KnownComponent] -> Syntax syntaxForm2ComponentFile cs =   syntaxForm2 render $ \str1 _fstatus1 str2 -> do     guardComponentName str1     c <- matchComponentName cs str1     orNoThingIn "component" (cinfoStrName c) $ do       (filepath, _) <- matchComponentFile [c] str2-      return (TargetComponent (cinfoPackage c) (cinfoName c)+      return (TargetComponent (cinfoPackageId c) (cinfoName c)                               (FileTarget filepath))   where     render (TargetComponent p c (FileTarget f)) =@@ -1224,14 +1240,15 @@       [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)]     render _ = [] -syntaxForm3MetaCwdFilter :: Syntax-syntaxForm3MetaCwdFilter =+syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax+syntaxForm3MetaCwdFilter ps =   syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do     guardNamespaceMeta str1     guardNamespaceCwd str2     kfilter <- matchComponentKindFilter str3-    return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter))+    return (TargetPackage TargetImplicitCwd pids (Just kfilter))   where+    pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]     render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =       [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)]     render _ = []@@ -1240,17 +1257,23 @@ -- -- > cabal build :pkg:foo ---syntaxForm3MetaNamespacePackage :: [PackageInfo] -> Syntax+syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax syntaxForm3MetaNamespacePackage pinfo =   syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do     guardNamespaceMeta      str1     guardNamespacePackage   str2     guardPackageName        str3     p <- matchPackage pinfo str3 noFileStatus-    return (TargetPackage TargetExplicitNamed p Nothing)+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)+      KnownPackageName pn ->+        return (TargetPackageNamed pn Nothing)   where-    render (TargetPackage TargetExplicitNamed p Nothing) =+    render (TargetPackage TargetExplicitNamed [p] Nothing) =       [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)]+    render (TargetPackageNamed pn Nothing) =+      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)]     render _ = []  -- | Syntax: package : namespace : component@@ -1259,19 +1282,26 @@ -- > cabal build foo/:lib:foo -- > cabal build foo.cabal:lib:foo ---syntaxForm3PackageKindComponent :: [PackageInfo] -> Syntax+syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax syntaxForm3PackageKindComponent ps =   syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do     guardPackage         str1 fstatus1     ckind <- matchComponentKind str2     guardComponentName   str3     p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentKindAndName (pinfoComponents p) ckind str3-      return (TargetComponent p (cinfoName c) WholeComponent)+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str3+          return (TargetComponent pinfoId (cinfoName c) WholeComponent)+      KnownPackageName pn ->+        let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in+        return (TargetComponentUnknown pn (Right cn) WholeComponent)   where     render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p c)]+      [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)]+    render (TargetComponentUnknown pn (Right c) WholeComponent) =+      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)]     render _ = []  -- | Syntax: package : component : module@@ -1280,29 +1310,37 @@ -- > cabal build foo/:foo:Data.Foo -- > cabal build foo.cabal:foo:Data.Foo ---syntaxForm3PackageComponentModule :: [PackageInfo] -> Syntax+syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax syntaxForm3PackageComponentModule ps =   syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do     guardPackage str1 fstatus1     guardComponentName str2     guardModuleName    str3     p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentName (pinfoComponents p) str2-      orNoThingIn "component" (cinfoStrName c) $ do-        let ms = cinfoModules c-        m <- matchModuleName ms str3-        return (TargetComponent p (cinfoName c) (ModuleTarget m))+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          c <- matchComponentName pinfoComponents str2+          orNoThingIn "component" (cinfoStrName c) $ do+            let ms = cinfoModules c+            m <- matchModuleName ms str3+            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))+      KnownPackageName pn -> do+        let cn = mkUnqualComponentName  str2+        m     <- matchModuleNameUnknown str3+        return (TargetComponentUnknown pn (Left cn) (ModuleTarget m))   where     render (TargetComponent p c (ModuleTarget m)) =       [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)]+    render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) =+      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)]     render _ = []  -- | Syntax: namespace : component : module -- -- > cabal build lib:foo:Data.Foo ---syntaxForm3KindComponentModule :: [ComponentInfo] -> Syntax+syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax syntaxForm3KindComponentModule cs =   syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do     ckind <- matchComponentKind str1@@ -1312,11 +1350,11 @@     orNoThingIn "component" (cinfoStrName c) $ do       let ms = cinfoModules c       m <- matchModuleName ms str3-      return (TargetComponent (cinfoPackage c) (cinfoName c)+      return (TargetComponent (cinfoPackageId c) (cinfoName c)                               (ModuleTarget m))   where     render (TargetComponent p c (ModuleTarget m)) =-      [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) (dispM m)]+      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)]     render _ = []  -- | Syntax: package : component : filename@@ -1325,27 +1363,35 @@ -- > cabal build foo/:foo:Data/Foo.hs -- > cabal build foo.cabal:foo:Data/Foo.hs ---syntaxForm3PackageComponentFile :: [PackageInfo] -> Syntax+syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax syntaxForm3PackageComponentFile ps =   syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do     guardPackage         str1 fstatus1     guardComponentName   str2     p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentName (pinfoComponents p) str2-      orNoThingIn "component" (cinfoStrName c) $ do-        (filepath, _) <- matchComponentFile [c] str3-        return (TargetComponent p (cinfoName c) (FileTarget filepath))+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          c <- matchComponentName pinfoComponents str2+          orNoThingIn "component" (cinfoStrName c) $ do+            (filepath, _) <- matchComponentFile [c] str3+            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))+      KnownPackageName pn ->+        let cn = mkUnqualComponentName str2+            filepath = str3 in+        return (TargetComponentUnknown pn (Left cn) (FileTarget filepath))   where     render (TargetComponent p c (FileTarget f)) =       [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f]+    render (TargetComponentUnknown pn (Left c) (FileTarget f)) =+      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f]     render _ = []  -- | Syntax: namespace : component : filename -- -- > cabal build lib:foo:Data/Foo.hs ---syntaxForm3KindComponentFile :: [ComponentInfo] -> Syntax+syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax syntaxForm3KindComponentFile cs =   syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do     ckind <- matchComponentKind str1@@ -1353,29 +1399,35 @@     c <- matchComponentKindAndName cs ckind str2     orNoThingIn "component" (cinfoStrName c) $ do       (filepath, _) <- matchComponentFile [c] str3-      return (TargetComponent (cinfoPackage c) (cinfoName c)+      return (TargetComponent (cinfoPackageId c) (cinfoName c)                               (FileTarget filepath))   where     render (TargetComponent p c (FileTarget f)) =-      [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) f]+      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f]     render _ = [] -syntaxForm3NamespacePackageFilter :: [PackageInfo] -> Syntax+syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm3NamespacePackageFilter ps =   syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do     guardNamespacePackage str1     guardPackageName      str2     p <- matchPackage  ps str2 noFileStatus     kfilter <- matchComponentKindFilter str3-    return (TargetPackage TargetExplicitNamed p (Just kfilter))+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))+      KnownPackageName pn ->+        return (TargetPackageNamed pn (Just kfilter))   where-    render (TargetPackage TargetExplicitNamed p (Just kfilter)) =+    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =       [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)]+    render (TargetPackageNamed pn (Just kfilter)) =+      [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)]     render _ = []  -- -syntaxForm4MetaNamespacePackageFilter :: [PackageInfo] -> Syntax+syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm4MetaNamespacePackageFilter ps =   syntaxForm4 render $ \str1 str2 str3 str4 -> do     guardNamespaceMeta    str1@@ -1383,17 +1435,23 @@     guardPackageName      str3     p <- matchPackage  ps str3 noFileStatus     kfilter <- matchComponentKindFilter str4-    return (TargetPackage TargetExplicitNamed p (Just kfilter))+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))+      KnownPackageName pn ->+        return (TargetPackageNamed pn (Just kfilter))   where-    render (TargetPackage TargetExplicitNamed p (Just kfilter)) =+    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =       [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)]+    render (TargetPackageNamed pn (Just kfilter)) =+      [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)]     render _ = []  -- | Syntax: :pkg : package : namespace : component -- -- > cabal build :pkg:foo:lib:foo ---syntaxForm5MetaNamespacePackageKindComponent :: [PackageInfo] -> Syntax+syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax syntaxForm5MetaNamespacePackageKindComponent ps =   syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do     guardNamespaceMeta    str1@@ -1402,12 +1460,19 @@     ckind <- matchComponentKind str4     guardComponentName    str5     p <- matchPackage  ps str3 noFileStatus-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentKindAndName (pinfoComponents p) ckind str5-      return (TargetComponent p (cinfoName c) WholeComponent)+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str5+          return (TargetComponent pinfoId (cinfoName c) WholeComponent)+      KnownPackageName pn ->+        let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in+        return (TargetComponentUnknown pn (Right cn) WholeComponent)   where     render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)]+      [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)]+    render (TargetComponentUnknown pn (Right c) WholeComponent) =+      [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)]     render _ = []  -- | Syntax: :pkg : package : namespace : component : module : module@@ -1415,7 +1480,7 @@ -- > cabal build :pkg:foo:lib:foo:module:Data.Foo -- syntaxForm7MetaNamespacePackageKindComponentNamespaceModule-  :: [PackageInfo] -> Syntax+  :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps =   syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do     guardNamespaceMeta    str1@@ -1425,17 +1490,27 @@     guardComponentName    str5     guardNamespaceModule  str6     p <- matchPackage  ps str3 noFileStatus-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentKindAndName (pinfoComponents p) ckind str5-      orNoThingIn "component" (cinfoStrName c) $ do-        let ms = cinfoModules c-        m <- matchModuleName ms str7-        return (TargetComponent p (cinfoName c) (ModuleTarget m))+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str5+          orNoThingIn "component" (cinfoStrName c) $ do+            let ms = cinfoModules c+            m <- matchModuleName ms str7+            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))+      KnownPackageName pn -> do+        let cn = mkComponentName pn ckind (mkUnqualComponentName str2)+        m <- matchModuleNameUnknown str7+        return (TargetComponentUnknown pn (Right cn) (ModuleTarget m))   where     render (TargetComponent p c (ModuleTarget m)) =       [TargetStringFileStatus7 "" "pkg" (dispP p)-                               (dispK c) (dispC p c)+                               (dispCK c) (dispC p c)                                "module" (dispM m)]+    render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) =+      [TargetStringFileStatus7 "" "pkg" (dispPN pn)+                               (dispCK c) (dispC' pn c)+                               "module" (dispM m)]     render _ = []  -- | Syntax: :pkg : package : namespace : component : file : filename@@ -1443,7 +1518,7 @@ -- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs -- syntaxForm7MetaNamespacePackageKindComponentNamespaceFile-  :: [PackageInfo] -> Syntax+  :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps =   syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do     guardNamespaceMeta    str1@@ -1453,16 +1528,26 @@     guardComponentName    str5     guardNamespaceFile    str6     p <- matchPackage  ps str3 noFileStatus-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentKindAndName (pinfoComponents p) ckind str5-      orNoThingIn "component" (cinfoStrName c) $ do-        (filepath,_) <- matchComponentFile [c] str7-        return (TargetComponent p (cinfoName c) (FileTarget filepath))+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (display (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str5+          orNoThingIn "component" (cinfoStrName c) $ do+            (filepath,_) <- matchComponentFile [c] str7+            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))+      KnownPackageName pn ->+        let cn       = mkComponentName pn ckind (mkUnqualComponentName str5)+            filepath = str7 in+        return (TargetComponentUnknown pn (Right cn) (FileTarget filepath))   where     render (TargetComponent p c (FileTarget f)) =       [TargetStringFileStatus7 "" "pkg" (dispP p)-                               (dispK c) (dispC p c)+                               (dispCK c) (dispC p c)                                "file" f]+    render (TargetComponentUnknown pn (Right c) (FileTarget f)) =+      [TargetStringFileStatus7 "" "pkg" (dispPN pn)+                               (dispCK c) (dispC' pn c)+                               "file" f]     render _ = []  @@ -1470,17 +1555,17 @@ -- Syntax utils -- -type Match1 = String -> FileStatus -> Match (TargetSelector PackageInfo)+type Match1 = String -> FileStatus -> Match TargetSelector type Match2 = String -> FileStatus -> String-              -> Match (TargetSelector PackageInfo)+              -> Match TargetSelector type Match3 = String -> FileStatus -> String -> String-              -> Match (TargetSelector PackageInfo)+              -> Match TargetSelector type Match4 = String -> String -> String -> String-              -> Match (TargetSelector PackageInfo)+              -> Match TargetSelector type Match5 = String -> String -> String -> String -> String-              -> Match (TargetSelector PackageInfo)+              -> Match TargetSelector type Match7 = String -> String -> String -> String -> String -> String -> String-              -> Match (TargetSelector PackageInfo)+              -> Match TargetSelector  syntaxForm1 :: Renderer -> Match1 -> Syntax syntaxForm2 :: Renderer -> Match2 -> Syntax@@ -1531,12 +1616,24 @@ dispP :: Package p => p -> String dispP = display . packageName -dispC :: Package p => p -> ComponentName -> String-dispC = componentStringName+dispPN :: PackageName -> String+dispPN = display -dispK :: ComponentName -> String-dispK = showComponentKindShort . componentKind+dispC :: PackageId -> ComponentName -> String+dispC = componentStringName . packageName +dispC' :: PackageName -> ComponentName -> String+dispC' = componentStringName++dispCN :: UnqualComponentName -> String+dispCN = display++dispK :: ComponentKind -> String+dispK = showComponentKindShort++dispCK :: ComponentName -> String+dispCK = dispK . componentKind+ dispF :: ComponentKind -> String dispF = showComponentKindFilterShort @@ -1548,39 +1645,88 @@ -- Package and component info -- -data PackageInfo = PackageInfo {+data KnownTargets = KnownTargets {+       knownPackagesAll       :: [KnownPackage],+       knownPackagesPrimary   :: [KnownPackage],+       knownPackagesOther     :: [KnownPackage],+       knownComponentsAll     :: [KnownComponent],+       knownComponentsPrimary :: [KnownComponent],+       knownComponentsOther   :: [KnownComponent]+     }+  deriving Show++data KnownPackage =+     KnownPackage {        pinfoId          :: PackageId,-       pinfoLocation    :: PackageLocation (),        pinfoDirectory   :: Maybe (FilePath, FilePath),        pinfoPackageFile :: Maybe (FilePath, FilePath),-       pinfoComponents  :: [ComponentInfo]+       pinfoComponents  :: [KnownComponent]      }-  -- not instance of Show due to recursive construction+   | KnownPackageName {+       pinfoName        :: PackageName+     }+  deriving Show -data ComponentInfo = ComponentInfo {-       cinfoName    :: ComponentName,-       cinfoStrName :: ComponentStringName,-       cinfoPackage :: PackageInfo,-       cinfoSrcDirs :: [FilePath],-       cinfoModules :: [ModuleName],-       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)-       cinfoCFiles  :: [FilePath],-       cinfoJsFiles :: [FilePath]+data KnownComponent = KnownComponent {+       cinfoName      :: ComponentName,+       cinfoStrName   :: ComponentStringName,+       cinfoPackageId :: PackageId,+       cinfoSrcDirs   :: [FilePath],+       cinfoModules   :: [ModuleName],+       cinfoHsFiles   :: [FilePath],   -- other hs files (like main.hs)+       cinfoCFiles    :: [FilePath],+       cinfoJsFiles   :: [FilePath]      }-  -- not instance of Show due to recursive construction+  deriving Show  type ComponentStringName = String -instance Package PackageInfo where-  packageId = pinfoId+knownPackageName :: KnownPackage -> PackageName+knownPackageName KnownPackage{pinfoId}       = packageName pinfoId+knownPackageName KnownPackageName{pinfoName} = pinfoName -selectPackageInfo :: (Applicative m, Monad m) => DirActions m-                  -> SourcePackage (PackageLocation a) -> m PackageInfo-selectPackageInfo dirActions@DirActions{..}-                  SourcePackage {+emptyKnownTargets :: KnownTargets+emptyKnownTargets = KnownTargets [] [] [] [] [] []++getKnownTargets :: (Applicative m, Monad m)+                => DirActions m+                -> [PackageSpecifier (SourcePackage (PackageLocation a))]+                -> m KnownTargets+getKnownTargets dirActions@DirActions{..} pkgs = do+    pinfo <- mapM (collectKnownPackageInfo dirActions) pkgs+    cwd   <- getCurrentDirectory+    let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo+    return KnownTargets {+      knownPackagesAll       = pinfo,+      knownPackagesPrimary   = ppinfo,+      knownPackagesOther     = opinfo,+      knownComponentsAll     = allComponentsIn pinfo,+      knownComponentsPrimary = allComponentsIn ppinfo,+      knownComponentsOther   = allComponentsIn opinfo+    }+  where+    selectPrimaryPackage :: FilePath+                         -> [KnownPackage]+                         -> ([KnownPackage], [KnownPackage])+    selectPrimaryPackage cwd = partition isPkgDirCwd+      where+        isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) }+          | dir == cwd = True+        isPkgDirCwd _  = False+    allComponentsIn ps =+      [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ]+++collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m+                        -> PackageSpecifier (SourcePackage (PackageLocation a))+                        -> m KnownPackage+collectKnownPackageInfo _ (NamedPackage pkgname _props) =+    return (KnownPackageName pkgname)+collectKnownPackageInfo dirActions@DirActions{..}+                  (SpecificSourcePackage SourcePackage {                     packageDescription = pkg,                     packageSource      = loc-                  } = do+                  }) = do     (pkgdir, pkgfile) <-       case loc of         --TODO: local tarballs, remote tarballs etc@@ -1596,38 +1742,34 @@                  )         _ -> return (Nothing, Nothing)     let pinfo =-          PackageInfo {+          KnownPackage {             pinfoId          = packageId pkg,-            pinfoLocation    = fmap (const ()) loc,             pinfoDirectory   = pkgdir,             pinfoPackageFile = pkgfile,-            pinfoComponents  = selectComponentInfo pinfo+            pinfoComponents  = collectKnownComponentInfo                                  (flattenPackageDescription pkg)           }     return pinfo  -selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo]-selectComponentInfo pinfo pkg =-    [ ComponentInfo {-        cinfoName    = componentName c,-        cinfoStrName = componentStringName pkg (componentName c),-        cinfoPackage = pinfo,-        cinfoSrcDirs = ordNub (hsSourceDirs bi),---                       [ pkgroot </> srcdir---                       | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo)---                       , srcdir <- hsSourceDirs bi ],-        cinfoModules = ordNub (componentModules c),-        cinfoHsFiles = ordNub (componentHsFiles c),-        cinfoCFiles  = ordNub (cSources bi),-        cinfoJsFiles = ordNub (jsSources bi)+collectKnownComponentInfo :: PackageDescription -> [KnownComponent]+collectKnownComponentInfo pkg =+    [ KnownComponent {+        cinfoName      = componentName c,+        cinfoStrName   = componentStringName (packageName pkg) (componentName c),+        cinfoPackageId = packageId pkg,+        cinfoSrcDirs   = ordNub (hsSourceDirs bi),+        cinfoModules   = ordNub (componentModules c),+        cinfoHsFiles   = ordNub (componentHsFiles c),+        cinfoCFiles    = ordNub (cSources bi),+        cinfoJsFiles   = ordNub (jsSources bi)       }     | c <- pkgComponents pkg     , let bi = componentBuildInfo c ]  -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName-componentStringName pkg CLibName          = display (packageName pkg)+componentStringName :: PackageName -> ComponentName -> ComponentStringName+componentStringName pkgname CLibName    = display pkgname componentStringName _ (CSubLibName name) = unUnqualComponentName name componentStringName _ (CFLibName name)  = unUnqualComponentName name componentStringName _ (CExeName   name) = unUnqualComponentName name@@ -1677,7 +1819,7 @@ guardNamespaceFile = guardToken ["file"] "'file' namespace"  guardToken :: [String] -> String -> String -> Match ()-guardToken tokens msg s +guardToken tokens msg s   | caseFold s `elem` tokens = increaseConfidence   | otherwise                = matchErrorExpected msg s @@ -1694,7 +1836,7 @@ componentKind (CTestName  _) = TestKind componentKind (CBenchName _) = BenchKind -cinfoKind :: ComponentInfo -> ComponentKind+cinfoKind :: KnownComponent -> ComponentKind cinfoKind = componentKind . cinfoName  matchComponentKind :: String -> Match ComponentKind@@ -1787,25 +1929,32 @@ guardPackageFile str _ = matchErrorExpected "package .cabal file" str  -matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo+matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackage pinfo = \str fstatus ->     orNoThingIn "project" "" $           matchPackageName pinfo str-    <//> (matchPackageDir  pinfo str fstatus+    <//> (matchPackageNameUnknown str+     <|>  matchPackageDir  pinfo str fstatus      <|>  matchPackageFile pinfo str fstatus)  -matchPackageName :: [PackageInfo] -> String -> Match PackageInfo+matchPackageName :: [KnownPackage] -> String -> Match KnownPackage matchPackageName ps = \str -> do     guard (validPackageName str)     orNoSuchThing "package" str-                  (map (display . packageName) ps) $+                  (map (display . knownPackageName) ps) $       increaseConfidenceFor $-        matchInexactly caseFold (display . packageName) ps str+        matchInexactly caseFold (display . knownPackageName) ps str  -matchPackageDir :: [PackageInfo]-                -> String -> FileStatus -> Match PackageInfo+matchPackageNameUnknown :: String -> Match KnownPackage+matchPackageNameUnknown str = do+    pn <- matchParse str+    unknownMatch (KnownPackageName pn)+++matchPackageDir :: [KnownPackage]+                -> String -> FileStatus -> Match KnownPackage matchPackageDir ps = \str fstatus ->     case fstatus of       FileStatusExistsDir canondir ->@@ -1815,10 +1964,10 @@       _ -> mzero   where     dirs = [ ((dabs,drel),p)-           | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ]+           | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ]  -matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo+matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackageFile ps = \str fstatus -> do     case fstatus of       FileStatusExistsFile canonfile ->@@ -1828,7 +1977,7 @@       _ -> mzero   where     files = [ ((fabs,frel),p)-            | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ]+            | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ]  --TODO: test outcome when dir exists but doesn't match any known one @@ -1851,15 +2000,15 @@                         || c == '_' || c == '-' || c == '\''  -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo+matchComponentName :: [KnownComponent] -> String -> Match KnownComponent matchComponentName cs str =     orNoSuchThing "component" str (map cinfoStrName cs)   $ increaseConfidenceFor   $ matchInexactly caseFold cinfoStrName cs str  -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String-                          -> Match ComponentInfo+matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String+                          -> Match KnownComponent matchComponentKindAndName cs ckind str =     orNoSuchThing (showComponentKind ckind ++ " component") str                   (map render cs)@@ -1901,31 +2050,38 @@   $ matchInexactly caseFold (display . fst) ms str  +matchModuleNameUnknown :: String -> Match ModuleName+matchModuleNameUnknown str =+    expecting "module" str+  $ increaseConfidenceFor+  $ matchParse str++ ------------------------------ -- Matching file targets -- -matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus-                            -> Match (FilePath, PackageInfo)+matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus+                            -> Match (FilePath, KnownPackage) matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =     increaseConfidenceFor $       matchDirectoryPrefix pkgdirs filepath   where     pkgdirs = [ (dir, p)-              | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ]+              | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] matchPackageDirectoryPrefix _ _ = mzero  -matchComponentFile :: [ComponentInfo] -> String-                   -> Match (FilePath, ComponentInfo)+matchComponentFile :: [KnownComponent] -> String+                   -> Match (FilePath, KnownComponent) matchComponentFile cs str =     orNoSuchThing "file" str [] $         matchComponentModuleFile cs str     <|> matchComponentOtherFile  cs str  -matchComponentOtherFile :: [ComponentInfo] -> String-                        -> Match (FilePath, ComponentInfo)+matchComponentOtherFile :: [KnownComponent] -> String+                        -> Match (FilePath, KnownComponent) matchComponentOtherFile cs =     matchFile       [ (file, c)@@ -1936,8 +2092,8 @@       ]  -matchComponentModuleFile :: [ComponentInfo] -> String-                         -> Match (FilePath, ComponentInfo)+matchComponentModuleFile :: [KnownComponent] -> String+                         -> Match (FilePath, KnownComponent) matchComponentModuleFile cs str = do     matchFile       [ (normalise (d </> toFilePath m), c)@@ -1979,11 +2135,22 @@ -- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we -- can run a matcher against an input using 'findMatch'. ---data Match a = NoMatch      Confidence [MatchError]-             | ExactMatch   Confidence [a]-             | InexactMatch Confidence [a]+data Match a = NoMatch           !Confidence [MatchError]+             | Match !MatchClass !Confidence [a]   deriving Show +-- | The kind of match, inexact or exact. We keep track of this so we can+-- prefer exact over inexact matches. The 'Ord' here is important: we try+-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom.+--+data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package+                          --   name without it being a specific known package+                | Inexact -- ^ Matches a known thing inexactly+                          --   e.g. matches a known package case insensitively+                | Exact   -- ^ Exactly matches a known thing,+                          --   e.g. matches a known package case sensitively+  deriving (Show, Eq, Ord)+ type Confidence = Int  data MatchError = MatchErrorExpected String String            -- thing got@@ -1993,12 +2160,11 @@   instance Functor Match where-    fmap _ (NoMatch      d ms) = NoMatch      d ms-    fmap f (ExactMatch   d xs) = ExactMatch   d (fmap f xs)-    fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)+    fmap _ (NoMatch d ms) = NoMatch d ms+    fmap f (Match m d xs) = Match m d (fmap f xs)  instance Applicative Match where-    pure a = ExactMatch 0 [a]+    pure a = Match Exact 0 [a]     (<*>)  = ap  instance Alternative Match where@@ -2006,13 +2172,20 @@     (<|>) = matchPlus  instance Monad Match where-    return                  = pure-    NoMatch      d ms >>= _ = NoMatch d ms-    ExactMatch   d xs >>= f = addDepth d-                            $ msum (map f xs)-    InexactMatch d xs >>= f = addDepth d . forceInexact-                            $ msum (map f xs)+    return             = pure+    NoMatch d ms >>= _ = NoMatch d ms+    Match m d xs >>= f =+      -- To understand this, it needs to be read in context with the+      -- implementation of 'matchPlus' below+      case msum (map f xs) of+        Match m' d' xs' -> Match (min m m') (d + d') xs'+        -- The minimum match class is the one we keep. The match depth is+        -- tracked but not used in the Match case. +        NoMatch  d' ms  -> NoMatch          (d + d') ms+        -- Here is where we transfer the depth we were keeping track of in+        -- the Match case over to the NoMatch case where it finally gets used.+ instance MonadPlus Match where     mzero = empty     mplus = matchPlus@@ -2022,15 +2195,6 @@  infixl 3 <//> -addDepth :: Confidence -> Match a -> Match a-addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs-addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs-addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs--forceInexact :: Match a -> Match a-forceInexact (ExactMatch d ys) = InexactMatch d ys-forceInexact m                 = m- -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the -- ambiguous matches.@@ -2038,20 +2202,16 @@ -- This operator is associative, has unit 'mzero' and is also commutative. -- matchPlus :: Match a -> Match a -> Match a-matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =-  ExactMatch (max d1 d2) (xs ++ xs')-matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a-matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a-matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b-matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =-  InexactMatch (max d1 d2) (xs ++ xs')-matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a-matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b-matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b-matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')-                                             | d1 >  d2  = a-                                             | d1 <  d2  = b-                                             | otherwise = NoMatch d1 (ms ++ ms')+matchPlus a@(Match _ _ _ )   (NoMatch _ _) = a+matchPlus   (NoMatch _ _ ) b@(Match _ _ _) = b+matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b)+  | d_a > d_b = a  -- We only really make use of the depth in the NoMatch case.+  | d_a < d_b = b+  | otherwise = NoMatch d_a (ms_a ++ ms_b)+matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b)+  | m_a > m_b = a  -- exact over inexact+  | m_a < m_b = b  -- exact over inexact+  | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b)  -- | Combine two matchers. This is similar to 'matchPlus' with the -- difference that an exact match from the left matcher shadows any exact@@ -2060,7 +2220,7 @@ -- This operator is associative, has unit 'mzero' and is not commutative. -- matchPlusShadowing :: Match a -> Match a -> Match a-matchPlusShadowing a@(ExactMatch _ _)  _ = a+matchPlusShadowing a@(Match Exact _ _) _ = a matchPlusShadowing a                   b = matchPlus a b  @@ -2088,26 +2248,28 @@ orNoThingIn _ _ m = m  increaseConfidence :: Match ()-increaseConfidence = ExactMatch 1 [()]+increaseConfidence = Match Exact 1 [()]  increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r  nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a-nubMatchesBy _  (NoMatch      d msgs) = NoMatch      d msgs-nubMatchesBy eq (ExactMatch   d xs)   = ExactMatch   d (nubBy eq xs)-nubMatchesBy eq (InexactMatch d xs)   = InexactMatch d (nubBy eq xs)+nubMatchesBy _  (NoMatch d msgs) = NoMatch d msgs+nubMatchesBy eq (Match m d xs)   = Match m d (nubBy eq xs)  -- | Lift a list of matches to an exact match. -- exactMatches, inexactMatches :: [a] -> Match a  exactMatches [] = mzero-exactMatches xs = ExactMatch 0 xs+exactMatches xs = Match Exact 0 xs  inexactMatches [] = mzero-inexactMatches xs = InexactMatch 0 xs+inexactMatches xs = Match Inexact 0 xs +unknownMatch :: a -> Match a+unknownMatch x = Match Unknown 0 [x]+ tryEach :: [a] -> Match a tryEach = exactMatches @@ -2122,15 +2284,18 @@ -- findMatch :: Match a -> MaybeAmbiguous a findMatch match = case match of-  NoMatch    _ msgs  -> None msgs-  ExactMatch   _ [x] -> Unambiguous x-  InexactMatch _ [x] -> Unambiguous x-  ExactMatch   _  [] -> error "findMatch: impossible: ExactMatch []"-  InexactMatch _  [] -> error "findMatch: impossible: InexactMatch []"-  ExactMatch   _  xs -> Ambiguous True  xs-  InexactMatch _  xs -> Ambiguous False xs+  NoMatch _ msgs -> None msgs+  Match _ _  [x] -> Unambiguous x+  Match m d   [] -> error $ "findMatch: impossible: " ++ show match'+                      where match' = Match m d [] :: Match ()+                    -- TODO: Maybe use Data.List.NonEmpty inside+                    -- Match so that this case would be correct+                    -- by construction?+  Match m _   xs -> Ambiguous m xs -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a]+data MaybeAmbiguous a = None [MatchError]+                      | Unambiguous a+                      | Ambiguous MatchClass [a]   deriving Show  @@ -2172,7 +2337,10 @@     -- the map of canonicalised keys to groups of inexact matches     m' = Map.mapKeysWith (++) cannonicalise m +matchParse :: Text a => String -> Match a+matchParse = maybe mzero return . simpleParse + ------------------------------ -- Utils --@@ -2180,25 +2348,42 @@ caseFold :: String -> String caseFold = lowercase +-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the+-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's+-- primary library from named private libraries.+--+mkComponentName :: PackageName+                -> ComponentKind+                -> UnqualComponentName+                -> ComponentName+mkComponentName pkgname ckind ucname =+  case ckind of+    LibKind+      | packageNameToUnqualComponentName pkgname == ucname+                  -> CLibName+      | otherwise -> CSubLibName ucname+    FLibKind      -> CFLibName   ucname+    ExeKind       -> CExeName    ucname+    TestKind      -> CTestName   ucname+    BenchKind     -> CBenchName  ucname + ------------------------------ -- Example inputs --  {--ex1pinfo :: [PackageInfo]+ex1pinfo :: [KnownPackage] ex1pinfo =   [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $-    PackageInfo {+    KnownPackage {       pinfoId          = PackageIdentifier (mkPackageName "foo") (mkVersion [1]),-      pinfoLocation    = LocalUnpackedPackage "/the/foo",       pinfoDirectory   = Just ("/the/foo", "foo"),       pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"),       pinfoComponents  = []     }-  , PackageInfo {+  , KnownPackage {       pinfoId          = PackageIdentifier (mkPackageName "bar") (mkVersion [1]),-      pinfoLocation    = LocalUnpackedPackage "/the/foo",       pinfoDirectory   = Just ("/the/bar", "bar"),       pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"),       pinfoComponents  = []@@ -2208,7 +2393,7 @@     addComponent n ds ms p =       p {         pinfoComponents =-            ComponentInfo n (componentStringName (pinfoId p) n)+            KnownComponent n (componentStringName (pinfoId p) n)                           p ds (map mkMn ms)                           [] [] []           : pinfoComponents p@@ -2232,13 +2417,13 @@ -}  {--ex_cs :: [ComponentInfo]+ex_cs :: [KnownComponent] ex_cs =   [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])   , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])   ]     where-    mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms)+    mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms)     mkMn :: String -> ModuleName     mkMn  = fromJust . simpleParse     pkgid :: PackageIdentifier

Distribution/Client/Targets.hs view

@@ -18,11 +18,6 @@   UserTarget(..),   readUserTargets, -  -- * Package specifiers-  PackageSpecifier(..),-  pkgSpecifierTarget,-  pkgSpecifierConstraints,-   -- * Resolving user targets to package specifiers   resolveUserTargets, @@ -60,11 +55,9 @@          , PackageIdentifier(..), packageName, packageVersion ) import Distribution.Types.Dependency import Distribution.Client.Types-         ( PackageLocation(..)-         , ResolvedPkgLoc, UnresolvedSourcePackage )+         ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage+         , PackageSpecifier(..) ) -import           Distribution.Solver.Types.ConstraintSource-import           Distribution.Solver.Types.LabeledPackageConstraint import           Distribution.Solver.Types.OptionalStanza import           Distribution.Solver.Types.PackageConstraint import           Distribution.Solver.Types.PackagePath@@ -82,7 +75,7 @@          ( RepoContext(..) )  import Distribution.PackageDescription-         ( GenericPackageDescription, parseFlagAssignment )+         ( GenericPackageDescription, parseFlagAssignment, nullFlagAssignment ) import Distribution.Version          ( nullVersion, thisVersion, anyVersion, isAnyVersion ) import Distribution.Text@@ -91,16 +84,8 @@ import Distribution.Simple.Utils          ( die', warn, lowercase ) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec          ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe )-#else-import Distribution.PackageDescription.Parse-         ( readGenericPackageDescription, parseGenericPackageDescription, ParseResult(..) )-import Distribution.Simple.Utils-         ( fromUTF8, ignoreBOM )-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-#endif  -- import Data.List ( find, nub ) import Data.Either@@ -179,46 +164,6 @@   -- --------------------------------------------------------------- * Package specifier--- ---------------------------------------------------------------- | A fully or partially resolved reference to a package.----data PackageSpecifier pkg =--     -- | A partially specified reference to a package (either source or-     -- installed). It is specified by package name and optionally some-     -- required properties. Use a dependency resolver to pick a specific-     -- package satisfying these properties.-     ---     NamedPackage PackageName [PackageProperty]--     -- | A fully specified source package.-     ---   | SpecificSourcePackage pkg-  deriving (Eq, Show, Generic)--instance Binary pkg => Binary (PackageSpecifier pkg)--pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName-pkgSpecifierTarget (NamedPackage name _)       = name-pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg--pkgSpecifierConstraints :: Package pkg-                        => PackageSpecifier pkg -> [LabeledPackageConstraint]-pkgSpecifierConstraints (NamedPackage name props) = map toLpc props-  where-    toLpc prop = LabeledPackageConstraint-                 (PackageConstraint (scopeToplevel name) prop)-                 ConstraintSourceUserTarget-pkgSpecifierConstraints (SpecificSourcePackage pkg)  =-    [LabeledPackageConstraint pc ConstraintSourceUserTarget]-  where-    pc = PackageConstraint-         (scopeToplevel $ packageName pkg)-         (PackagePropertyVersion $ thisVersion (packageVersion pkg))---- ------------------------------------------------------------ -- * Parsing and checking user targets -- ------------------------------------------------------------ @@ -444,7 +389,7 @@              , let props = [ PackagePropertyVersion vrange                            | not (isAnyVersion vrange) ]                         ++ [ PackagePropertyFlags flags-                           | not (null flags) ] ]+                           | not (nullFlagAssignment flags) ] ]      UserTargetLocalDir dir ->       return [ PackageTargetLocation (LocalUnpackedPackage dir) ]@@ -558,15 +503,8 @@           _                 -> False      parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription-#ifdef CABAL_PARSEC     parsePackageDescription' bs =          parseGenericPackageDescriptionMaybe (BS.toStrict bs)-#else-    parsePackageDescription' content =-      case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of-        ParseOk _ pkg -> Just pkg-        _             -> Nothing-#endif  -- ------------------------------------------------------------ -- * Checking package targets@@ -629,10 +567,13 @@     case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of       []          -> return ()       ambiguities -> die' verbosity $ unlines-                             [    "The package name '" ++ display name-                               ++ "' is ambiguous. It could be: "-                               ++ intercalate ", " (map display matches)-                             | (name, matches) <- ambiguities ]+                         [    "There is no package named '" ++ display name ++ "'. "+                           ++ (if length matches > 1+                               then "However, the following package names exist: "+                               else "However, the following package name exists: ")+                           ++ intercalate ", " [ "'" ++ display m ++ "'" | m <- matches]+                           ++ "."+                         | (name, matches) <- ambiguities ]      case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of       []   -> return ()@@ -651,19 +592,22 @@  data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] --- | Given a package name and a list of matching names, figure out which one it--- might be referring to. If there is an exact case-sensitive match then that's--- ok. If it matches just one package case-insensitively then that's also ok.--- The only problem is if it matches multiple packages case-insensitively, in--- that case it is ambiguous.+-- | Given a package name and a list of matching names, figure out+-- which one it might be referring to. If there is an exact+-- case-sensitive match then that's ok (i.e. returned via+-- 'Unambiguous'). If it matches just one package case-insensitively+-- or if it matches multiple packages case-insensitively, in that case+-- the result is 'Ambiguous'. --+-- Note: Before cabal 2.2, when only a single package matched+--       case-insensitively it would be considered 'Unambigious'.+-- disambiguatePackageName :: PackageNameEnv                         -> PackageName                         -> MaybeAmbiguous PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name =     case nub (pkgNameLookup name) of       []      -> None-      [name'] -> Unambiguous name'       names   -> case find (name==) names of                    Just name' -> Unambiguous name'                    Nothing    -> Ambiguous names

Distribution/Client/Types.hs view

@@ -20,15 +20,19 @@ ----------------------------------------------------------------------------- module Distribution.Client.Types where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Package          ( Package(..), HasMungedPackageId(..), HasUnitId(..)+         , PackageIdentifier(..), packageVersion, packageName          , PackageInstalled(..), newSimpleUnitId ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo, installedComponentId, sourceComponentName ) import Distribution.PackageDescription          ( FlagAssignment ) import Distribution.Version-         ( VersionRange )+         ( VersionRange, nullVersion, thisVersion ) import Distribution.Types.ComponentId          ( ComponentId ) import Distribution.Types.MungedPackageId@@ -39,7 +43,7 @@ import Distribution.Types.UnitId          ( UnitId ) import Distribution.Types.PackageName-         ( PackageName )+         ( PackageName, mkPackageName ) import Distribution.Types.ComponentName          ( ComponentName(..) ) @@ -48,19 +52,22 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps          ( ComponentDeps )+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageConstraint 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 Distribution.Simple.Utils (ordNub)+import Distribution.Text (Text(..)) -import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI) import Control.Exception          ( Exception, SomeException )-import Data.Typeable (Typeable)-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary(..))+import qualified Text.PrettyPrint as Disp   newtype Username = Username { unUsername :: String }@@ -140,11 +147,11 @@  -- | A ConfiguredId is a package ID for a configured package. ----- Once we configure a source package we know it's UnitId. It is still+-- Once we configure a source package we know its UnitId. It is still -- however useful in lots of places to also know the source ID for the package. -- We therefore bundle the two. ----- An already installed package of course is also "configured" (all it's+-- An already installed package of course is also "configured" (all its -- configuration parameters and dependencies have been specified). data ConfiguredId = ConfiguredId {     confSrcId  :: PackageId@@ -208,7 +215,49 @@ -- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc + -- ------------------------------------------------------------+-- * Package specifier+-- ------------------------------------------------------------++-- | A fully or partially resolved reference to a package.+--+data PackageSpecifier pkg =++     -- | A partially specified reference to a package (either source or+     -- installed). It is specified by package name and optionally some+     -- required properties. Use a dependency resolver to pick a specific+     -- package satisfying these properties.+     --+     NamedPackage PackageName [PackageProperty]++     -- | A fully specified source package.+     --+   | SpecificSourcePackage pkg+  deriving (Eq, Show, Generic)++instance Binary pkg => Binary (PackageSpecifier pkg)++pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName+pkgSpecifierTarget (NamedPackage name _)       = name+pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg++pkgSpecifierConstraints :: Package pkg+                        => PackageSpecifier pkg -> [LabeledPackageConstraint]+pkgSpecifierConstraints (NamedPackage name props) = map toLpc props+  where+    toLpc prop = LabeledPackageConstraint+                 (PackageConstraint (scopeToplevel name) prop)+                 ConstraintSourceUserTarget+pkgSpecifierConstraints (SpecificSourcePackage pkg)  =+    [LabeledPackageConstraint pc ConstraintSourceUserTarget]+  where+    pc = PackageConstraint+         (ScopeTarget $ packageName pkg)+         (PackagePropertyVersion $ thisVersion (packageVersion pkg))+++-- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------ @@ -319,6 +368,11 @@ instance Binary Repo  -- | Check if this is a remote repo+isRepoRemote :: Repo -> Bool+isRepoRemote RepoLocal{} = False+isRepoRemote _           = True++-- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo maybeRepoRemote (RepoLocal    _localDir) = Nothing maybeRepoRemote (RepoRemote r _localDir) = Just r@@ -370,3 +424,167 @@ instance Binary SomeException where   put _ = return ()   get = fail "cannot serialise exceptions"+++-- ------------------------------------------------------------+-- * --allow-newer/--allow-older+-- ------------------------------------------------------------++-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,+-- it may make sense to move these definitions to the Solver.Types+-- module++-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)+newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)++-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)+newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)++-- | Generic data type for policy when relaxing bounds in dependencies.+-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending+-- on whether or not you are relaxing an lower or upper bound+-- (respectively).+data RelaxDeps =++  -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.+  --+  -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all+  -- dependencies, never choose versions newer (resp. older) than allowed.+    RelaxDepsSome [RelaxedDep]++  -- | Ignore upper (resp. lower) bounds in dependencies on all packages.+  --+  -- __Note__: This is should be semantically equivalent to+  --+  -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]+  --+  -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')+  | RelaxDepsAll+  deriving (Eq, Read, Show, Generic)++-- | Dependencies can be relaxed either for all packages in the install plan, or+-- only for some packages.+data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject+                deriving (Eq, Read, Show, Generic)++-- | Specify the scope of a relaxation, i.e. limit which depending+-- packages are allowed to have their version constraints relaxed.+data RelaxDepScope = RelaxDepScopeAll+                     -- ^ Apply relaxation in any package+                   | RelaxDepScopePackage !PackageName+                     -- ^ Apply relaxation to in all versions of a package+                   | RelaxDepScopePackageId !PackageId+                     -- ^ Apply relaxation to a specific version of a package only+                   deriving (Eq, Read, Show, Generic)++-- | Modifier for dependency relaxation+data RelaxDepMod = RelaxDepModNone  -- ^ Default semantics+                 | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints+                 deriving (Eq, Read, Show, Generic)++-- | Express whether to relax bounds /on/ @all@ packages, or a single package+data RelaxDepSubject = RelaxDepSubjectAll+                     | RelaxDepSubjectPkg !PackageName+                     deriving (Eq, Ord, Read, Show, Generic)++instance Text RelaxedDep where+  disp (RelaxedDep scope rdmod subj) = case scope of+      RelaxDepScopeAll          -> Disp.text "all:"           Disp.<> modDep+      RelaxDepScopePackage   p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep+      RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep+    where+      modDep = case rdmod of+               RelaxDepModNone  -> disp subj+               RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj++  parse = RelaxedDep <$> scopeP <*> modP <*> parse+    where+      -- "greedy" choices+      scopeP =           (pure RelaxDepScopeAll  <* Parse.char '*' <* Parse.char ':')+               Parse.<++ (pure RelaxDepScopeAll  <* Parse.string "all:")+               Parse.<++ (RelaxDepScopePackageId <$> pidP  <* Parse.char ':')+               Parse.<++ (RelaxDepScopePackage   <$> parse <* Parse.char ':')+               Parse.<++ (pure RelaxDepScopeAll)++      modP =           (pure RelaxDepModCaret <* Parse.char '^')+             Parse.<++ (pure RelaxDepModNone)++      -- | Stricter 'PackageId' parser which doesn't overlap with 'PackageName' parser+      pidP = do+          p0 <- parse+          when (pkgVersion p0 == nullVersion) Parse.pfail+          pure p0++instance Text RelaxDepSubject where+  disp RelaxDepSubjectAll      = Disp.text "all"+  disp (RelaxDepSubjectPkg pn) = disp pn++  parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn+    where+      pkgn = do+          pn <- parse+          pure (if (pn == mkPackageName "all")+                then RelaxDepSubjectAll+                else RelaxDepSubjectPkg pn)++instance Text RelaxDeps where+  disp rd | not (isRelaxDeps rd) = Disp.text "none"+  disp (RelaxDepsSome pkgs)      = Disp.fsep .+                                   Disp.punctuate Disp.comma .+                                   map disp $ pkgs+  disp RelaxDepsAll              = Disp.text "all"++  parse =           (const mempty        <$> ((Parse.string "none" Parse.++++                                               Parse.string "None") <* Parse.eof))+          Parse.<++ (const RelaxDepsAll  <$> ((Parse.string "all"  Parse.++++                                               Parse.string "All"  Parse.++++                                               Parse.string "*")  <* Parse.eof))+          Parse.<++ (      RelaxDepsSome <$> parseOptCommaList parse)++instance Binary RelaxDeps+instance Binary RelaxDepMod+instance Binary RelaxDepScope+instance Binary RelaxDepSubject+instance Binary RelaxedDep+instance Binary AllowNewer+instance Binary AllowOlder++-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations+--+-- Equivalent to @isRelaxDeps = (/= 'mempty')@+isRelaxDeps :: RelaxDeps -> Bool+isRelaxDeps (RelaxDepsSome [])    = False+isRelaxDeps (RelaxDepsSome (_:_)) = True+isRelaxDeps RelaxDepsAll          = True++-- | 'RelaxDepsAll' is the /absorbing element/+instance Semigroup RelaxDeps where+  -- identity element+  RelaxDepsSome []    <> r                   = r+  l@(RelaxDepsSome _) <> RelaxDepsSome []    = l+  -- absorbing element+  l@RelaxDepsAll      <> _                   = l+  (RelaxDepsSome   _) <> r@RelaxDepsAll      = r+  -- combining non-{identity,absorbing} elements+  (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)++-- | @'RelaxDepsSome' []@ is the /identity element/+instance Monoid RelaxDeps where+  mempty  = RelaxDepsSome []+  mappend = (<>)++instance Semigroup AllowNewer where+  AllowNewer x <> AllowNewer y = AllowNewer (x <> y)++instance Semigroup AllowOlder where+  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)++instance Monoid AllowNewer where+  mempty  = AllowNewer mempty+  mappend = (<>)++instance Monoid AllowOlder where+  mempty  = AllowOlder mempty+  mappend = (<>)

Distribution/Client/Update.hs view

@@ -15,40 +15,48 @@     ( update     ) where +import Distribution.Simple.Setup+         ( fromFlag )+import Distribution.Client.Compat.Directory+         ( setModificationTime ) import Distribution.Client.Types          ( Repo(..), RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils          ( DownloadResult(..) ) import Distribution.Client.FetchUtils          ( downloadIndex )+import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.IndexUtils-         ( updateRepoIndexCache, Index(..) )+         ( updateRepoIndexCache, Index(..), writeIndexTimestamp+         , currentIndexTimestamp, indexBaseName ) import Distribution.Client.JobControl          ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup-         ( RepoContext(..) )+         ( RepoContext(..), UpdateFlags(..) )+import Distribution.Text+         ( display ) import Distribution.Verbosity-         ( Verbosity )  import Distribution.Simple.Utils-         ( writeFileAtomic, warn, notice )+         ( writeFileAtomic, warn, notice, noticeNoWrap )  import qualified Data.ByteString.Lazy       as BS import Distribution.Client.GZipUtils (maybeDecompress)-import System.FilePath (dropExtension)-import Data.Maybe (catMaybes)+import System.FilePath ((<.>), dropExtension)+import Data.Maybe (mapMaybe) import Data.Time (getCurrentTime)+import Control.Monad  import qualified Hackage.Security.Client as Sec  -- | 'update' downloads the package list from all known servers-update :: Verbosity -> RepoContext -> IO ()-update verbosity repoCtxt | null (repoContextRepos repoCtxt) = do+update :: Verbosity -> UpdateFlags -> RepoContext -> IO ()+update verbosity _ repoCtxt | null (repoContextRepos repoCtxt) = do   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."-update verbosity repoCtxt = do+update verbosity updateFlags repoCtxt = do   let repos       = repoContextRepos repoCtxt-      remoteRepos = catMaybes (map maybeRepoRemote repos)+      remoteRepos = mapMaybe maybeRepoRemote repos   case remoteRepos of     [] -> return ()     [remoteRepo] ->@@ -58,23 +66,30 @@             $ "Downloading the latest package lists from: "             : map (("- " ++) . remoteRepoName) remoteRepos   jobCtrl <- newParallelJobControl (length repos)-  mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos+  mapM_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos   mapM_ (\_ -> collectJob jobCtrl) repos -updateRepo :: Verbosity -> RepoContext -> Repo -> IO ()-updateRepo verbosity repoCtxt repo = do+updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO ()+updateRepo verbosity updateFlags repoCtxt repo = do   transport <- repoContextGetTransport repoCtxt   case repo of     RepoLocal{..} -> return ()     RepoRemote{..} -> do       downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir       case downloadResult of-        FileAlreadyInCache -> return ()+        FileAlreadyInCache ->+          setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime         FileDownloaded indexPath -> do           writeFileAtomic (dropExtension indexPath) . maybeDecompress                                                   =<< BS.readFile indexPath           updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)     RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do+      let index = RepoIndex repoCtxt repo+      -- NB: This may be a nullTimestamp if we've never updated before+      current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo+      -- NB: always update the timestamp, even if we didn't actually+      -- download anything+      writeIndexTimestamp index (fromFlag (updateIndexState updateFlags))       ce <- if repoContextIgnoreExpiry repoCtxt               then Just `fmap` getCurrentTime               else return Nothing@@ -83,6 +98,13 @@       -- (If all access to the cache goes through hackage-security this can go)       case updated of         Sec.NoUpdates  ->-          return ()+          setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime         Sec.HasUpdates ->-          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+          updateRepoIndexCache verbosity index+      -- TODO: This will print multiple times if there are multiple+      -- repositories: main problem is we don't have a way of updating+      -- a specific repo.  Once we implement that, update this.+      when (current_ts /= nullTimestamp) $+        noticeNoWrap verbosity $+          "To revert to previous state run:\n" +++          "    cabal update --index-state='" ++ display current_ts ++ "'\n"

Distribution/Client/Upload.hs view

@@ -25,7 +25,7 @@ import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory import Control.Monad (forM_, when, foldM)-import Data.Maybe (catMaybes)+import Data.Maybe (mapMaybe) import Data.Char (isSpace)  type Auth = Maybe (String, String)@@ -170,7 +170,7 @@   Password password <- maybe promptPassword return mPassword   let auth        = (username, password)       repos       = repoContextRepos repoCtxt-      remoteRepos = catMaybes (map maybeRepoRemote repos)+      remoteRepos = mapMaybe maybeRepoRemote repos   forM_ remoteRepos $ \remoteRepo ->       do dotCabal <- defaultCabalDir          let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo

Distribution/Client/Utils.hs view

@@ -3,8 +3,8 @@ module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy                                  , readMaybe-                                 , inDir, withEnv, logDirChange-                                 , withExtraPathEnv+                                 , inDir, withEnv, withEnvOverrides+                                 , logDirChange, withExtraPathEnv                                  , determineNumJobs, numberOfProcessors                                  , removeExistingFile                                  , withTempFileName@@ -33,6 +33,8 @@ import Data.Bits          ( (.|.), shiftL, shiftR ) import System.FilePath+import Control.Monad+         ( mapM, mapM_, zipWithM_ ) import Data.List          ( groupBy ) import Foreign.C.Types ( CInt(..) )@@ -132,6 +134,27 @@   m `Exception.finally` (case mb_old of     Nothing -> unsetEnv k     Just old -> setEnv k old)++-- | Executes the action with a list of environment variables and+-- corresponding overrides, where+--+-- * @'Just' v@ means \"set the environment variable's value to @v@\".+-- * 'Nothing' means \"unset the environment variable\".+--+-- Warning: This operation is NOT thread-safe, because current+-- environment is a process-global concept.+withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a+withEnvOverrides overrides m = do+  mb_olds <- mapM lookupEnv envVars+  mapM_ (uncurry update) overrides+  m `Exception.finally` zipWithM_ update envVars mb_olds+   where+    envVars :: [String]+    envVars = map fst overrides++    update :: String -> Maybe FilePath -> IO ()+    update var Nothing    = unsetEnv var+    update var (Just val) = setEnv var val  -- | Executes the action, increasing the PATH environment -- in some way

Distribution/Client/Win32SelfUpgrade.hs view

@@ -17,7 +17,7 @@ -- | Windows inherited a design choice from DOS that while initially innocuous -- has rather unfortunate consequences. It maintains the invariant that every -- open file has a corresponding name on disk. One positive consequence of this--- is that an executable can always find it's own executable file. The downside+-- is that an executable can always find its own executable file. The downside -- is that a program cannot be deleted or upgraded while it is running without -- hideous workarounds. This module implements one such hideous workaround. --

Distribution/Client/World.hs view

@@ -29,9 +29,13 @@     getContents,   ) where +import Prelude (sequence)+import Distribution.Client.Compat.Prelude hiding (getContents)+ import Distribution.Types.Dependency import Distribution.PackageDescription-         ( FlagAssignment, mkFlagName, unFlagName )+         ( FlagAssignment, mkFlagAssignment, unFlagAssignment+         , mkFlagName, unFlagName ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Simple.Utils@@ -41,17 +45,15 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Exception ( catchIO ) import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ( (<>), (<+>) )   import Data.Char as Char  import Data.List-         ( unionBy, deleteFirstsBy, nubBy )+         ( unionBy, deleteFirstsBy ) import System.IO.Error          ( isDoesNotExistError ) import qualified Data.ByteString.Lazy.Char8 as B-import Prelude hiding (getContents)   data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment@@ -122,21 +124,21 @@   instance Text WorldPkgInfo where-  disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags+  disp (WorldPkgInfo dep flags) = disp dep Disp.<+> dispFlags (unFlagAssignment flags)     where       dispFlags [] = Disp.empty       dispFlags fs = Disp.text "--flags="-                  <> Disp.doubleQuotes (flagAssToDoc fs)+                  <<>> Disp.doubleQuotes (flagAssToDoc fs)       flagAssToDoc = foldr (\(fname,val) flagAssDoc ->                              (if not val then Disp.char '-'                                          else Disp.empty)-                             Disp.<> Disp.text (unFlagName fname)+                             <<>> Disp.text (unFlagName fname)                              Disp.<+> flagAssDoc)                            Disp.empty   parse = do       dep <- parse       Parse.skipSpaces-      flagAss <- Parse.option [] parseFlagAssignment+      flagAss <- Parse.option mempty parseFlagAssignment       return $ WorldPkgInfo dep flagAss     where       parseFlagAssignment :: Parse.ReadP r FlagAssignment@@ -145,7 +147,7 @@           Parse.skipSpaces           _ <- Parse.char '='           Parse.skipSpaces-          inDoubleQuotes $ Parse.many1 flag+          mkFlagAssignment <$> (inDoubleQuotes $ Parse.many1 flag)         where           inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a           inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')

+ Distribution/Solver/Compat/Prelude.hs view

@@ -0,0 +1,19 @@+-- to suppress WARNING in "Distribution.Compat.Prelude.Internal"+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- | This module does two things:+--+-- * Acts as a compatiblity layer, like @base-compat@.+--+-- * Provides commonly used imports.+--+-- This module is a superset of "Distribution.Compat.Prelude" (which+-- this module re-exports)+--+module Distribution.Solver.Compat.Prelude+  ( module Distribution.Compat.Prelude.Internal+  , Prelude.IO+  ) where++import Prelude (IO)+import Distribution.Compat.Prelude.Internal hiding (IO)

Distribution/Solver/Modular.hs view

@@ -1,5 +1,5 @@ module Distribution.Solver.Modular-         ( modularResolver, SolverConfig(..)) 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@@ -9,25 +9,41 @@ -- and finally, we have to convert back the resulting install -- plan. -import Data.Map as M-         ( fromListWith )+import Prelude ()+import Distribution.Client.Compat.Prelude++import qualified Data.Map as M+import Data.Set (Set)+import Data.Ord import Distribution.Compat.Graph          ( IsNode(..) )+import Distribution.Compiler+         ( CompilerInfo ) import Distribution.Solver.Modular.Assignment-         ( toCPs )+         ( Assignment, toCPs ) import Distribution.Solver.Modular.ConfiguredConversion          ( convCP )+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.IndexConversion          ( convPIs ) import Distribution.Solver.Modular.Log-         ( logToProgress )+         ( SolverFailure(..), logToProgress ) import Distribution.Solver.Modular.Package          ( PN ) import Distribution.Solver.Modular.Solver-         ( SolverConfig(..), solve )+         ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )+import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.DependencyResolver+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.PkgConfigDb+         ( PkgConfigDb )+import Distribution.Solver.Types.Progress+import Distribution.Solver.Types.Variable import Distribution.System          ( Platform(..) ) import Distribution.Simple.Utils@@ -38,9 +54,8 @@ -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =-  fmap (uncurry postprocess)                           $ -- convert install plan-  logToProgress (solverVerbosity sc) (maxBackjumps sc) $ -- convert log format into progress format-  solve sc cinfo idx pkgConfigDB pprefs gcs pns+  fmap (uncurry postprocess) $ -- convert install plan+  solve' sc cinfo idx pkgConfigDB pprefs gcs pns     where       -- Indices have to be converted into solver-specific uniform index.       idx    = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx@@ -58,3 +73,100 @@       -- Helper function to extract the PN from a constraint.       pcName :: PackageConstraint -> PN       pcName (PackageConstraint scope _) = scopeToPackageName scope++-- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display+-- in the error case.+--+-- 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.+--+-- 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+-- subtree containing the path that the solver took to the first backjump. This+-- conflict set helps explain why the solver reached the backjump limit, because+-- the first backjump contributes to reaching the backjump limit. Additionally,+-- the solver is much more likely to be able to finish traversing this subtree+-- before the backjump limit, since its size is linear (not exponential) in the+-- number of goal choices. We create it by pruning all children after the first+-- successful child under each node in the original tree, so that there is at+-- most one valid choice at each level. Then we use the final conflict set from+-- that run to generate an error message, as in the case where the solver found+-- that there was no solution.+--+-- Using the full log from a rerun of the solver ensures that the log is+-- complete, i.e., it shows the whole chain of dependencies from the user+-- targets to the conflicting packages.+solve' :: SolverConfig+       -> CompilerInfo+       -> Index+       -> PkgConfigDb+       -> (PN -> PackagePreferences)+       -> Map PN [LabeledPackageConstraint]+       -> Set PN+       -> Progress String String (Assignment, RevDepMap)+solve' sc cinfo idx pkgConfigDB pprefs gcs pns =+    foldProgress Step createErrorMsg Done (runSolver sc)+  where+    runSolver :: SolverConfig+              -> Progress String SolverFailure (Assignment, RevDepMap)+    runSolver sc' =+        logToProgress (solverVerbosity sc') (maxBackjumps sc') $ -- convert log format into progress format+        solve sc' cinfo idx pkgConfigDB pprefs gcs pns++    createErrorMsg :: SolverFailure+                   -> Progress String String (Assignment, RevDepMap)+    createErrorMsg (NoSolution cs        msg) =+        Fail $ rerunSolverForErrorMsg cs msg+    createErrorMsg (BackjumpLimitReached msg) =+        Step ("Backjump limit reached. Rerunning dependency solver to generate "+              ++ "a final conflict set for the search tree containing the "+              ++ "first backjump.") $+        foldProgress Step f Done $+        runSolver sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }+      where+        f :: SolverFailure -> Progress String String (Assignment, RevDepMap)+        f (NoSolution 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."++    rerunSolverForErrorMsg :: ConflictSet -> String -> String+    rerunSolverForErrorMsg cs finalMsg =+      let sc' = sc {+                    goalOrder = Just goalOrder'+                  , maxBackjumps = Just 0+                  }++          -- Preferring goals from the conflict set takes precedence over the+          -- original goal order.+          goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)++      in unlines ("Could not resolve dependencies:" : messages (runSolver sc'))+          ++ finalMsg++    messages :: Progress step fail done -> [step]+    messages = foldProgress (:) (const []) (const [])++-- | 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)

Distribution/Solver/Modular/Assignment.hs view

@@ -1,23 +1,20 @@ module Distribution.Solver.Modular.Assignment     ( Assignment(..)+    , PAssignment     , FAssignment     , SAssignment-    , PreAssignment(..)-    , extend     , toCPs     ) where -import Control.Applicative-import Control.Monad+import Prelude ()+import Distribution.Solver.Compat.Prelude hiding (pi)+ import Data.Array as A import Data.List as L import Data.Map as M import Data.Maybe-import Prelude hiding (pi) -import Language.Haskell.Extension (Extension, Language)--import Distribution.PackageDescription (FlagAssignment) -- from Cabal+import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal  import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) import qualified Distribution.Solver.Types.ComponentDeps as CD@@ -29,17 +26,11 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.LabeledGraph import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Version  -- | A (partial) package assignment. Qualified package names -- are associated with instances. type PAssignment    = Map QPN I --- | A (partial) package preassignment. Qualified package names--- are associated with constrained instances. Constrained instances--- record constraints about the instances that can still be chosen,--- and in the extreme case fix a concrete instance.-type PPreAssignment = Map QPN (CI QPN) type FAssignment    = Map QFN Bool type SAssignment    = Map QSN Bool @@ -47,55 +38,6 @@ data Assignment = A PAssignment FAssignment SAssignment   deriving (Show, Eq) --- | A preassignment comprises knowledge about variables, but not--- necessarily fixed values.-data PreAssignment = PA PPreAssignment FAssignment SAssignment---- | Extend a package preassignment.------ Takes the variable that causes the new constraints, a current preassignment--- and a set of new dependency constraints.------ We're trying to extend the preassignment with each dependency one by one.--- Each dependency is for a particular variable. We check if we already have--- constraints for that variable in the current preassignment. If so, we're--- trying to merge the constraints.------ Either returns a witness of the conflict that would arise during the merge,--- 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-       -> Var QPN-       -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet, [Dep QPN]) PPreAssignment-extend extSupported langSupported pkgPresent var = foldM extendSingle-  where--    extendSingle :: PPreAssignment -> Dep QPN-                 -> Either (ConflictSet, [Dep QPN]) PPreAssignment-    extendSingle a (Ext  ext )  =-      if extSupported  ext  then Right a-                            else Left (varToConflictSet var, [Ext ext])-    extendSingle a (Lang lang)  =-      if langSupported lang then Right a-                            else Left (varToConflictSet var, [Lang lang])-    extendSingle a (Pkg pn vr)  =-      if pkgPresent pn vr then Right a-                          else Left (varToConflictSet var, [Pkg pn vr])-    extendSingle a (Dep is_exe qpn ci) =-      let ci' = M.findWithDefault (Constrained []) qpn a-      in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of-            Left (c, (d, d')) -> Left  (c, L.map (Dep is_exe qpn) (simplify (P qpn) d d'))-            Right x           -> Right x--    -- We're trying to remove trivial elements of the conflict. If we're just-    -- making a choice pkg == instance, and pkg => pkg == instance is a part-    -- of the conflict, then this info is clear from the context and does not-    -- have to be repeated.-    simplify v (Fixed _ var') c | v == var && var' == var = [c]-    simplify v c (Fixed _ var') | v == var && var' == var = [c]-    simplify _ c              d                           = [c, d]- -- | Delivers an ordered list of fully configured packages. -- -- TODO: This function is (sort of) ok. However, there's an open bug@@ -124,14 +66,14 @@     -- Determine the flags per package, by walking over and regrouping the     -- complete flag assignment by package.     fapp :: Map QPN FlagAssignment-    fapp = M.fromListWith (++) $-           L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $+    fapp = M.fromListWith mappend $+           L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $            M.toList $            fa     -- Stanzas per package.     sapp :: Map QPN [OptionalStanza]     sapp = M.fromListWith (++) $-           L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $+           L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $            M.toList $            sa     -- Dependencies per package.@@ -146,7 +88,7 @@     depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp   in     L.map (\ pi@(PI qpn _) -> CP pi-                                 (M.findWithDefault [] qpn fapp)-                                 (M.findWithDefault [] qpn sapp)+                                 (M.findWithDefault mempty qpn fapp)+                                 (M.findWithDefault mempty qpn sapp)                                  (depp' qpn))           ps

Distribution/Solver/Modular/Builder.hs view

@@ -1,5 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.Builder (buildTree) where+module Distribution.Solver.Modular.Builder (+    buildTree+  , splits -- for testing+  ) where  -- Building the search tree. --@@ -18,18 +21,18 @@  import Data.List as L import Data.Map as M+import Data.Set as S import Prelude hiding (sequence, mapM)  import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.PSQ (PSQ) import qualified Distribution.Solver.Modular.PSQ as P import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ComponentDeps (Component)+import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings @@ -43,11 +46,11 @@  -- | The state needed to build the search tree without creating any linked nodes. data BuildState = BS {-  index :: Index,                -- ^ information about packages and their dependencies-  rdeps :: RevDepMap,            -- ^ set of all package goals, completed and open, with reverse dependencies-  open  :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals)-  next  :: BuildType,            -- ^ kind of node to generate next-  qualifyOptions :: QualifyOptions -- ^ qualification options+  index :: Index,                   -- ^ information about packages and their dependencies+  rdeps :: RevDepMap,               -- ^ set of all package goals, completed and open, with reverse dependencies+  open  :: [OpenGoal],              -- ^ set of still open goals (flag and package goals)+  next  :: BuildType,               -- ^ kind of node to generate next+  qualifyOptions :: QualifyOptions  -- ^ qualification options }  -- | Map of available linking targets.@@ -57,65 +60,65 @@ -- -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals.-extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState+extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs   where-    go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState-    go g o []                                               = s { rdeps = g, open = o }-    go g o (ng@(OpenGoal (Flagged _ _ _ _)      _gr) : ngs) = go g (cons' ng () o) ngs+    go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState+    go g o []                                             = s { rdeps = g, open = o }+    go g o ((Flagged fn@(FN qpn _) fInfo t f)  : ngs) =+        go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs       -- Note: for 'Flagged' goals, we always insert, so later additions win.       -- This is important, because in general, if a goal is inserted twice,       -- the later addition will have better dependency information.-    go g o (ng@(OpenGoal (Stanza  _   _  )      _gr) : ngs) = go g (cons' ng () o) ngs-    go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs)-      | qpn == qpn'       = go                            g               o  ngs-          -- we ignore self-dependencies at this point; TODO: more care may be needed+    go g o ((Stanza sn@(SN qpn _) t)           : ngs) =+        go g (StanzaGoal sn t (flagGR qpn) : o) ngs+    go g o ((Simple (LDep dr (Dep _ qpn _)) c) : ngs)+      | qpn == qpn'       =+            -- We currently only add a self-dependency to the graph if it is+            -- between a package and its setup script. The edge creates a cycle+            -- and causes the solver to backtrack and choose a different+            -- instance for the setup script. We may need to track other+            -- self-dependencies once we implement component-based solving.+          case c of+            ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs+            _              -> go                                                    g  o ngs       | qpn `M.member` g  = go (M.adjust (addIfAbsent (c, qpn')) qpn g)   o  ngs-      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (cons' ng () o) ngs+      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (PkgGoal qpn (DependencyGoal dr) : o) ngs           -- code above is correct; insert/adjust have different arg order-    go g o (   (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs-    go g o (   (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs-    go g o (   (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs--    cons' = P.cons . forgetCompOpenGoal+    go g o ((Simple (LDep _dr (Ext _ext )) _)  : ngs) = go g o ngs+    go g o ((Simple (LDep _dr (Lang _lang))_)  : ngs) = go g o ngs+    go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs      addIfAbsent :: Eq a => a -> [a] -> [a]     addIfAbsent x xs = if x `elem` xs then xs else x : xs +    -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by+    -- its containing package.+    flagGR :: qpn -> GoalReason qpn+    flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty)+ -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->+scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo ->                     BuildState -> BuildState-scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s+scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s   where     -- Qualify all package names     qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps     -- Introduce all package flags-    qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs+    qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs     -- Combine new package and flag goals-    gs     = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps)+    gs     = qfdefs ++ qfdeps     -- NOTE:     --     -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially     -- multiple times, both via the flag declaration and via dependencies.-    -- The order is potentially important, because the occurrences via-    -- dependencies may record flag-dependency information. After a number-    -- of bugs involving computing this information incorrectly, however,-    -- we're currently not using carefully computed inter-flag dependencies-    -- anymore, but instead use 'simplifyVar' when computing conflict sets-    -- to map all flags of one package to a single flag for conflict set-    -- purposes, thereby treating them all as interdependent.-    ---    -- If we ever move to a more clever algorithm again, then the line above-    -- needs to be looked at very carefully, and probably be replaced by-    -- more systematically computed flag dependency information.  -- | Datatype that encodes what to build next data BuildType =-    Goals                                  -- ^ build a goal choice node-  | OneGoal (OpenGoal ())                  -- ^ build a node for this goal-  | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance-  deriving Show+    Goals              -- ^ build a goal choice node+  | OneGoal OpenGoal   -- ^ build a node for this goal+  | Instance QPN PInfo -- ^ build a tree for a concrete instance  build :: Linker BuildState -> Tree () QGoalReason build = ana go@@ -129,23 +132,17 @@ -- the tree. We select each open goal in turn, and before we descend, remove -- it from the queue of open goals. addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })-  | P.null gs = DoneF rdm ()-  | otherwise = GoalChoiceF rdm $ P.mapKeys close-                                $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })-                                $ P.splits gs+  | L.null gs = DoneF rdm ()+  | otherwise = GoalChoiceF rdm $ P.fromList+                                $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' }))+                                $ splits gs  -- If we have already picked a goal, then the choice depends on the kind -- of goal. -- -- For a package, we look up the instances available in the global info, -- and then handle each instance in turn.-addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =-  error "Distribution.Solver.Modular.Builder: addChildren called with Ext goal"-addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =-  error "Distribution.Solver.Modular.Builder: addChildren called with Lang goal"-addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =-  error "Distribution.Solver.Modular.Builder: addChildren called with Pkg goal"-addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =+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.@@ -154,16 +151,16 @@   case M.lookup pn idx of     Nothing  -> PChoiceF qpn rdm gr (W.fromList [])     Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->-                                                       ([], POption i Nothing, bs { next = Instance qpn i info gr }))+                                                       ([], POption i Nothing, bs { next = Instance qpn info }))                                                      (M.toList pis)))       -- TODO: data structure conversion is rather ugly here  -- For a flag, we create only two subtrees, and we create them in the order -- that is indicated by the flag default.-addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =+addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =   FChoiceF qfn rdm gr weak m b (W.fromList-    [([if b then 0 else 1], True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),-     ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])+    [([if b then 0 else 1], True,  (extendOpen qpn t bs) { next = Goals }),+     ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })])   where     trivial = L.null t && L.null f     weak = WeakOrTrivial $ unWeakOrTrivial w || trivial@@ -173,10 +170,10 @@ -- the stanza by replacing the False branch with failure) or preferences -- (try enabling the stanza if possible by moving the True branch first). -addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =+addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =   SChoiceF qsn rdm gr trivial (W.fromList-    [([0], False,                                                             bs  { next = Goals }),-     ([1], True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])+    [([0], False,                                                                  bs  { next = Goals }),+     ([1], True,  (extendOpen qpn t bs) { next = Goals })])   where     trivial = WeakOrTrivial (L.null t) @@ -184,8 +181,8 @@ -- and furthermore we update the set of goals. -- -- TODO: We could inline this above.-addChildren bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =-  addChildren ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)+addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) =+  addChildren ((scopedExtendOpen qpn fdeps fdefs bs)          { next = Goals })  {-------------------------------------------------------------------------------@@ -258,16 +255,44 @@         buildState = BS {             index = idx           , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)-          , open  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)+          , open  = L.map topLevelGoal qpns           , next  = Goals           , qualifyOptions = defaultQualifyOptions idx           }       , linkingState = M.empty       }   where-    -- Should a top-level goal allowed to be an executable style-    -- dependency? Well, I don't think it would make much difference-    topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal+    topLevelGoal qpn = PkgGoal qpn UserGoal -    qpns | ind       = makeIndependent igs+    qpns | ind       = L.map makeIndependent igs          | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs++{-------------------------------------------------------------------------------+  Goals+-------------------------------------------------------------------------------}++-- | Information needed about a dependency before it is converted into a Goal.+data OpenGoal =+    FlagGoal   (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason+  | StanzaGoal (SN QPN)       (FlaggedDeps QPN)                   QGoalReason+  | PkgGoal    QPN                                                QGoalReason++-- | Closes a goal, i.e., removes all the extraneous information that we+-- need only during the build phase.+close :: OpenGoal -> Goal QPN+close (FlagGoal   qfn _ _ _ gr) = Goal (F qfn) gr+close (StanzaGoal qsn _     gr) = Goal (S qsn) gr+close (PkgGoal    qpn       gr) = Goal (P qpn) gr++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Pairs each element of a list with the list resulting from removal of that+-- element from the original list.+splits :: [a] -> [(a, [a])]+splits = go id+  where+    go :: ([a] -> [a]) -> [a] -> [(a, [a])]+    go _ [] = []+    go f (x : xs) = (x, f xs) : go (f . (x :)) xs

Distribution/Solver/Modular/ConflictSet.hs view

@@ -131,7 +131,7 @@ #endif   Var QPN -> ConflictSet -> ConflictSet insert var cs = CS {-      conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs)+      conflictSetToSet = S.insert var (conflictSetToSet cs) #ifdef DEBUG_CONFLICT_SETS     , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif@@ -155,14 +155,14 @@ #endif   Var QPN -> ConflictSet singleton var = CS {-      conflictSetToSet = S.singleton (simplifyVar var)+      conflictSetToSet = S.singleton var #ifdef DEBUG_CONFLICT_SETS     , conflictSetOrigin = Node ?loc [] #endif     }  member :: Var QPN -> ConflictSet -> Bool-member var = S.member (simplifyVar var) . conflictSetToSet+member var = S.member var . conflictSetToSet  filter :: #ifdef DEBUG_CONFLICT_SETS@@ -182,7 +182,7 @@ #endif   [Var QPN] -> ConflictSet fromList vars = CS {-      conflictSetToSet = S.fromList (map simplifyVar vars)+      conflictSetToSet = S.fromList vars #ifdef DEBUG_CONFLICT_SETS     , conflictSetOrigin = Node ?loc [] #endif

Distribution/Solver/Modular/Cycles.hs view

@@ -11,7 +11,6 @@ import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component)@@ -25,9 +24,9 @@     go :: TreeF d c (Tree d c) -> Tree d c     go (PChoiceF qpn rdm gr                         cs) =         PChoice qpn rdm gr     $ fmap (checkChild qpn)   cs-    go (FChoiceF qfn@(FN (PI qpn _) _) rdm gr w m d cs) =+    go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) =         FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs-    go (SChoiceF qsn@(SN (PI qpn _) _) rdm gr w     cs) =+    go (SChoiceF qsn@(SN qpn _) rdm gr w     cs) =         SChoice qsn rdm gr w   $ fmap (checkChild qpn)   cs     go x                                                = inn x

Distribution/Solver/Modular/Dependency.hs view

@@ -1,59 +1,46 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}-#ifdef DEBUG_CONFLICT_SETS-{-# LANGUAGE ImplicitParams #-}-#endif module Distribution.Solver.Modular.Dependency (     -- * Variables     Var(..)-  , simplifyVar-  , varPI   , showVar+  , varPN     -- * Conflict sets   , ConflictSet   , ConflictMap   , CS.showConflictSet     -- * Constrained instances   , CI(..)-  , merge     -- * Flagged dependencies   , FlaggedDeps   , FlaggedDep(..)+  , LDep(..)   , Dep(..)-  , showDep+  , DependencyReason(..)+  , showDependencyReason   , flattenFlaggedDeps   , QualifyOptions(..)   , qualifyDeps   , unqualifyDeps-    -- ** Setting/forgetting components-  , forgetCompOpenGoal-  , setCompFlaggedDeps     -- * Reverse dependency map   , RevDepMap     -- * Goals   , Goal(..)   , GoalReason(..)   , QGoalReason-  , ResetVar(..)   , goalToVar-  , goalVarToConflictSet   , varToConflictSet-  , goalReasonToVars-    -- * Open goals-  , OpenGoal(..)-  , close+  , goalReasonToCS+  , dependencyReasonToCS   ) where -import Prelude hiding (pi)--import Data.Map (Map)-import qualified Data.List as L+import Prelude ()+import qualified Data.Map as M+import qualified Data.Set as S+import Distribution.Client.Compat.Prelude hiding (pi)  import Language.Haskell.Extension (Extension(..), Language(..)) -import Distribution.Text- import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package@@ -63,56 +50,16 @@  import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath--#ifdef DEBUG_CONFLICT_SETS-import GHC.Stack (CallStack)-#endif+import Distribution.Types.UnqualComponentName  {-------------------------------------------------------------------------------   Constrained instances -------------------------------------------------------------------------------} --- | Constrained instance. If the choice has already been made, this is--- a fixed instance, and we record the package name for which the choice--- is for convenience. Otherwise, it is a list of version ranges paired with--- the goals / variables that introduced them.-data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn]-  deriving (Eq, Show, Functor)--showCI :: CI QPN -> String-showCI (Fixed i _)      = "==" ++ showI i-showCI (Constrained vr) = showVR (collapse vr)---- | Merge constrained instances. We currently adopt a lazy strategy for--- merging, i.e., we only perform actual checking if one of the two choices--- is fixed. If the merge fails, we return a conflict set indicating the--- variables responsible for the failure, as well as the two conflicting--- fragments.------ Note that while there may be more than one conflicting pair of version--- ranges, we only return the first we find.------ TODO: Different pairs might have different conflict sets. We're--- obviously interested to return a conflict that has a "better" conflict--- set in the sense the it contains variables that allow us to backjump--- further. We might apply some heuristics here, such as to change the--- order in which we check the constraints.-merge ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  CI QPN -> CI QPN -> Either (ConflictSet, (CI QPN, CI QPN)) (CI QPN)-merge c@(Fixed i g1)       d@(Fixed j g2)-  | i == j                                    = Right c-  | otherwise                                 = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d))-merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...-  where-    go []              = Right c-    go (d@(vr, g2) : vrs)-      | checkVR vr v   = go vrs-      | otherwise      = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d]))-merge c@(Constrained _)    d@(Fixed _ _)      = merge d c-merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))+-- | Constrained instance. It represents the allowed instances for a package,+-- which can be either a fixed instance or a version range.+data CI = Fixed I | Constrained VR+  deriving (Eq, Show)  {-------------------------------------------------------------------------------   Flagged dependencies@@ -124,80 +71,68 @@ -- rather than having the dependencies indexed by component, each dependency -- defines what component it is in. ----- However, top-level goals are also modelled as dependencies, but of course--- these don't actually belong in any component of any package. Therefore, we--- parameterize 'FlaggedDeps' and derived datatypes with a type argument that--- specifies whether or not we have a component: we only ever instantiate this--- type argument with @()@ for top-level goals, or 'Component' for everything--- else (we could express this as a kind at the type-level, but that would--- require a very recent GHC).------ Note however, crucially, that independent of the type parameters, the list--- of dependencies underneath a flag choice or stanza choices _always_ uses--- Component as the type argument. This is important: when we pick a value for--- a flag, we _must_ know what component the new dependencies belong to, or--- else we don't be able to construct fine-grained reverse dependencies.-type FlaggedDeps comp qpn = [FlaggedDep comp qpn]+-- Note that each dependency is associated with a Component. We must know what+-- component the dependencies belong to, or else we won't be able to construct+-- fine-grained reverse dependencies.+type FlaggedDeps qpn = [FlaggedDep qpn]  -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees.-data FlaggedDep comp qpn =+data FlaggedDep qpn =     -- | Dependencies which are conditional on a flag choice.     Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)     -- | Dependencies which are conditional on whether or not a stanza     -- (e.g., a test suite or benchmark) is enabled.   | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)-    -- | Dependencies for which are always enabled, for the component-    -- 'comp' (or requested for the user, if comp is @()@).-  | Simple (Dep qpn) comp-  deriving (Eq, Show)+    -- | Dependencies which are always enabled, for the component 'comp'.+  | Simple (LDep qpn) Component  -- | Conversatively flatten out flagged dependencies -- -- NOTE: We do not filter out duplicates.-flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)]+flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] flattenFlaggedDeps = concatMap aux   where-    aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)]+    aux :: FlaggedDep qpn -> [(LDep qpn, Component)]     aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f     aux (Stanza  _   t)   = flattenFlaggedDeps t     aux (Simple d c)      = [(d, c)] -type TrueFlaggedDeps  qpn = FlaggedDeps Component qpn-type FalseFlaggedDeps qpn = FlaggedDeps Component qpn---- | Is this dependency on an executable-type IsExe = Bool+type TrueFlaggedDeps  qpn = FlaggedDeps qpn+type FalseFlaggedDeps qpn = FlaggedDeps qpn --- | A dependency (constraint) associates a package name with a--- constrained instance.+-- | A 'Dep' labeled with the reason it was introduced. ----- 'Dep' intentionally has no 'Functor' instance because the type variable+-- 'LDep' intentionally has no 'Functor' instance because the type variable -- is used both to record the dependencies as well as who's doing the -- depending; having a 'Functor' instance makes bugs where we don't distinguish--- these two far too likely. (By rights 'Dep' ought to have two type variables.)-data Dep qpn = Dep IsExe qpn (CI qpn)  -- ^ dependency on a package (possibly for executable-             | Ext  Extension          -- ^ dependency on a language extension-             | Lang Language           -- ^ dependency on a language version-             | Pkg  PkgconfigName VR   -- ^ dependency on a pkg-config package-  deriving (Eq, Show)+-- these two far too likely. (By rights 'LDep' ought to have two type variables.)+data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) -showDep :: Dep QPN -> String-showDep (Dep is_exe qpn (Fixed i v)            ) =-  (if P qpn /= v then showVar v ++ " => " else "") ++-  showQPN qpn ++-  (if is_exe then " (exe) " else "") ++ "==" ++ showI i-showDep (Dep is_exe qpn (Constrained [(vr, v)])) =-  showVar v ++ " => " ++ showQPN qpn ++-  (if is_exe then " (exe) " else "") ++ showVR vr-showDep (Dep is_exe qpn ci                     ) =-  showQPN qpn ++ (if is_exe then " (exe) " else "") ++ showCI ci-showDep (Ext ext)   = "requires " ++ display ext-showDep (Lang lang) = "requires " ++ display lang-showDep (Pkg pn vr) = "requires pkg-config package "-                      ++ display pn ++ display vr-                      ++ ", not found in the pkg-config database"+-- | A dependency (constraint) associates a package name with a constrained+-- instance. It can also represent other types of dependencies, such as+-- dependencies on language extensions.+data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI  -- ^ dependency on a package (possibly for executable)+             | Ext  Extension                          -- ^ dependency on a language extension+             | Lang Language                           -- ^ dependency on a language version+             | Pkg  PkgconfigName VR                   -- ^ dependency on a pkg-config package+  deriving Functor +-- | The reason that a dependency is active. It identifies the package and any+-- flag and stanza choices that introduced the dependency. It contains+-- everything needed for creating ConflictSets or describing conflicts in solver+-- log messages.+data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza)+  deriving (Functor, Eq, Show)++-- | Print the reason that a dependency was introduced.+showDependencyReason :: DependencyReason QPN -> String+showDependencyReason (DependencyReason qpn flags stanzas) =+    intercalate " " $+        showQPN qpn+      : map (uncurry showFlagValue) (M.toList flags)+     ++ map (\s -> showSBool s True) (S.toList stanzas)+ -- | Options for goal qualification (used in 'qualifyDeps') -- -- See also 'defaultQualifyOptions'@@ -220,34 +155,37 @@ -- -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent.-qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN+qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go   where-    go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN+    go :: FlaggedDeps PN -> FlaggedDeps QPN     go = map go1 -    go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN+    go1 :: FlaggedDep PN -> FlaggedDep QPN     go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)     go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)-    go1 (Simple dep comp)    = Simple (goD dep comp) comp+    go1 (Simple dep comp)    = Simple (goLDep dep comp) comp      -- Suppose package B has a setup dependency on package A.     -- This will be recorded as something like     ---    -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason])+    -- > LDep (DependencyReason "B") (Dep Nothing "A" (Constrained AnyVersion))     --     -- Observe that when we qualify this dependency, we need to turn that     -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier-    -- to the goal or the goal reason chain.+    -- to the DependencyReason.+    goLDep :: LDep PN -> Component -> LDep QPN+    goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp)+     goD :: Dep PN -> Component -> Dep QPN     goD (Ext  ext)    _    = Ext  ext     goD (Lang lang)   _    = Lang lang     goD (Pkg pkn vr)  _    = Pkg pkn vr-    goD (Dep is_exe dep ci) comp-      | is_exe      = Dep is_exe (Q (PackagePath ns (QualExe pn dep)) dep) (fmap (Q pp) ci)-      | qBase  dep  = Dep is_exe (Q (PackagePath ns (QualBase  pn)) dep) (fmap (Q pp) ci)-      | qSetup comp = Dep is_exe (Q (PackagePath ns (QualSetup pn)) dep) (fmap (Q pp) ci)-      | otherwise   = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci)+    goD (Dep mExe dep ci) comp+      | isJust mExe = Dep mExe (Q (PackagePath ns (QualExe   pn dep)) dep) ci+      | qBase  dep  = Dep mExe (Q (PackagePath ns (QualBase  pn    )) dep) ci+      | qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn    )) dep) ci+      | otherwise   = Dep mExe (Q (PackagePath ns inheritedQ        ) dep) ci      -- If P has a setup dependency on Q, and Q has a regular dependency on R, then     -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup@@ -278,56 +216,24 @@ -- what to link these dependencies to, we need to requalify @Q.B@ to become -- @Q'.B@; we do this by first removing all qualifiers and then calling -- 'qualifyDeps' again.-unqualifyDeps :: FlaggedDeps comp QPN -> FlaggedDeps comp PN+unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN unqualifyDeps = go   where-    go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN+    go :: FlaggedDeps QPN -> FlaggedDeps PN     go = map go1 -    go1 :: FlaggedDep comp QPN -> FlaggedDep comp PN+    go1 :: FlaggedDep QPN -> FlaggedDep PN     go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f)     go1 (Stanza  sn     t)   = Stanza  (fmap unq sn)     (go t)-    go1 (Simple dep comp)    = Simple (goD dep) comp+    go1 (Simple dep comp)    = Simple (goLDep dep) comp -    goD :: Dep QPN -> Dep PN-    goD (Dep is_exe qpn ci) = Dep is_exe (unq qpn) (fmap unq ci)-    goD (Ext  ext)   = Ext ext-    goD (Lang lang)  = Lang lang-    goD (Pkg pn vr)  = Pkg pn vr+    goLDep :: LDep QPN -> LDep PN+    goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep)      unq :: QPN -> PN     unq (Q _ pn) = pn  {--------------------------------------------------------------------------------  Setting/forgetting the Component--------------------------------------------------------------------------------}--forgetCompOpenGoal :: OpenGoal Component -> OpenGoal ()-forgetCompOpenGoal = mapCompOpenGoal $ const ()--setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn-setCompFlaggedDeps = mapCompFlaggedDeps . const--{--------------------------------------------------------------------------------  Auxiliary: Mapping over the Component goal--  We don't export these, because the only type instantiations for 'a' and 'b'-  here should be () or Component. (We could express this at the type level-  if we relied on newer versions of GHC.)--------------------------------------------------------------------------------}--mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b-mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr--mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn-mapCompFlaggedDeps = L.map . mapCompFlaggedDep--mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn-mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo   t f-mapCompFlaggedDep _ (Stanza  sn     t  ) = Stanza  sn       t-mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)--{-------------------------------------------------------------------------------   Reverse dependency map -------------------------------------------------------------------------------} @@ -346,86 +252,34 @@  -- | Reason why a goal is being added to a goal set. data GoalReason qpn =-    UserGoal-  | PDependency (PI qpn)-  | FDependency (FN qpn) Bool-  | SDependency (SN qpn)+    UserGoal                              -- introduced by a build target+  | DependencyGoal (DependencyReason qpn) -- introduced by a package   deriving (Eq, Show, Functor)  type QGoalReason = GoalReason QPN -class ResetVar f where-  resetVar :: Var qpn -> f qpn -> f qpn--instance ResetVar CI where-  resetVar v (Fixed i _)       = Fixed i v-  resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs)--instance ResetVar Dep where-  resetVar v (Dep is_exe qpn ci) = Dep is_exe qpn (resetVar v ci)-  resetVar _ (Ext ext)    = Ext ext-  resetVar _ (Lang lang)  = Lang lang-  resetVar _ (Pkg pn vr)  = Pkg pn vr--instance ResetVar Var where-  resetVar = const- goalToVar :: Goal a -> Var a goalToVar (Goal v _) = v --- | Compute a singleton conflict set from a goal, containing just--- the goal variable.------ NOTE: This is just a call to 'varToConflictSet' under the hood;--- the 'GoalReason' is ignored.-goalVarToConflictSet :: Goal QPN -> ConflictSet-goalVarToConflictSet (Goal g _gr) = varToConflictSet g- -- | Compute a singleton conflict set from a 'Var' varToConflictSet :: Var QPN -> ConflictSet varToConflictSet = CS.singleton --- | A goal reason is mostly just a variable paired with the--- decision we made for that variable (except for user goals,--- where we cannot really point to a solver variable). This--- function drops the decision and recovers the list of--- variables (which will be empty or contain one element).----goalReasonToVars :: GoalReason qpn -> [Var qpn]-goalReasonToVars UserGoal                 = []-goalReasonToVars (PDependency (PI qpn _)) = [P qpn]-goalReasonToVars (FDependency qfn _)      = [F qfn]-goalReasonToVars (SDependency qsn)        = [S qsn]--{--------------------------------------------------------------------------------  Open goals--------------------------------------------------------------------------------}---- | For open goals as they occur during the build phase, we need to store--- additional information about flags.-data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason-  deriving (Eq, Show)---- | Closes a goal, i.e., removes all the extraneous information that we--- need only during the build phase.-close :: OpenGoal comp -> Goal QPN-close (OpenGoal (Simple (Dep _ qpn _) _) gr) = Goal (P qpn) gr-close (OpenGoal (Simple (Ext     _) _) _ ) =-  error "Distribution.Solver.Modular.Dependency.close: called on Ext goal"-close (OpenGoal (Simple (Lang    _) _) _ ) =-  error "Distribution.Solver.Modular.Dependency.close: called on Lang goal"-close (OpenGoal (Simple (Pkg   _ _) _) _ ) =-  error "Distribution.Solver.Modular.Dependency.close: called on Pkg goal"-close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr-close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr--{--------------------------------------------------------------------------------  Version ranges paired with origins--------------------------------------------------------------------------------}+goalReasonToCS :: GoalReason QPN -> ConflictSet+goalReasonToCS UserGoal            = CS.empty+goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr -type VROrigin qpn = (VR, Var qpn)+-- | This function returns the solver variables responsible for the dependency.+-- It drops the flag and stanza values, which are only needed for log messages.+dependencyReasonToCS :: DependencyReason QPN -> ConflictSet+dependencyReasonToCS (DependencyReason qpn flags stanzas) =+    CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas)+  where+    -- Filter out any flags that introduced the dependency with both values.+    -- They don't need to be included in the conflict set, because changing the+    -- flag value can't remove the dependency.+    flagVars :: [Var QPN]+    flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth] --- | Helper function to collapse a list of version ranges with origins into--- a single, simplified, version range.-collapse :: [VROrigin qpn] -> VR-collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR+    stanzaToVar :: Stanza -> Var QPN+    stanzaToVar = S . SN qpn

Distribution/Solver/Modular/Explore.hs view

@@ -21,11 +21,10 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..)) --- | This function takes the variable we're currently considering, an--- initial conflict set and a--- list of children's logs. Each log yields either a solution or a--- conflict set. The result is a combined log for the parent node that--- has explored a prefix of the children.+-- | This function takes the variable we're currently considering, a+-- last conflict set and a list of children's logs. Each log yields+-- either a solution or a conflict set. The result is a combined log for+-- the parent node that has explored a prefix of the children. -- -- We can stop traversing the children's logs if we find an individual -- conflict set that does not contain the current variable. In this@@ -38,7 +37,7 @@ -- return it immediately. If all children contain conflict sets, we can -- take the union as the combined conflict set. ----- The initial conflict set corresponds to the justification that we+-- The last conflict set corresponds to the justification that we -- have to choose this goal at all. There is a reason why we have -- introduced the goal in the first place, and this reason is in conflict -- with the (virtual) option not to choose anything for the current@@ -47,8 +46,8 @@ backjump :: EnableBackjumping -> Var QPN          -> ConflictSet -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a)          -> ConflictMap -> ConflictSetLog a-backjump (EnableBackjumping enableBj) var initial xs =-    F.foldr combine logBackjump xs initial+backjump (EnableBackjumping enableBj) var lastCS xs =+    F.foldr combine avoidGoal xs CS.empty   where     combine :: forall a . (ConflictMap -> ConflictSetLog a)             -> (ConflictSet -> ConflictMap -> ConflictSetLog a)@@ -60,11 +59,15 @@           | enableBj && not (var `CS.member` cs) = logBackjump cs cm'           | otherwise                            = f (csAcc `CS.union` cs) cm' +    -- This function represents the option to not choose a value for this goal.+    avoidGoal :: ConflictSet -> ConflictMap -> ConflictSetLog a+    avoidGoal cs !cm = logBackjump (cs `CS.union` lastCS) (updateCM lastCS cm)+                                -- 'lastCS' instead of 'cs' here ---^+                                -- since we do not want to double-count the+                                -- additionally accumulated conflicts.+     logBackjump :: ConflictSet -> ConflictMap -> ConflictSetLog a-    logBackjump cs !cm = failWith (Failure cs Backjump) (cs, updateCM initial cm)-                                   -- 'intial' instead of 'cs' here ---^-                                   -- since we do not want to double-count the-                                   -- additionally accumulated conflicts.+    logBackjump cs cm = failWith (Failure cs Backjump) (cs, cm)  type ConflictSetLog = RetryLog Message (ConflictSet, ConflictMap) @@ -147,16 +150,16 @@ -- always have to consider that we could perhaps make choices that would -- avoid the existence of the goal completely. ----- Whenever we actual introduce a choice in the tree, we have already established+-- Whenever we actually introduce a choice in the tree, we have already established -- that the goal cannot be avoided. This is tracked in the "goal reason". -- The choice to avoid the goal therefore is a conflict between the goal itself -- and its goal reason. We build this set here, and pass it to the 'backjump'--- function as the initial conflict set.+-- function as the last conflict set. -- -- This has two effects: -- -- - In a situation where there are no choices available at all (this happens--- if an unknown package is requested), the initial conflict set becomes the+-- if an unknown package is requested), the last conflict set becomes the -- actual conflict set. -- -- - In a situation where all of the children's conflict sets contain the@@ -165,7 +168,7 @@ -- avoidSet :: Var QPN -> QGoalReason -> ConflictSet avoidSet var gr =-  CS.fromList (var : goalReasonToVars gr)+  CS.union (CS.singleton var) (goalReasonToCS gr)  -- | Interface. backjumpAndExplore :: EnableBackjumping

Distribution/Solver/Modular/Flag.hs view

@@ -6,38 +6,43 @@     , FN(..)     , QFN     , QSN+    , Stanza     , SN(..)     , WeakOrTrivial(..)+    , FlagValue(..)     , mkFlag-    , showFBool     , showQFN     , showQFNBool+    , showFlagValue     , showQSN     , showQSNBool+    , showSBool     ) where  import Data.Map as M import Prelude hiding (pi) -import Distribution.PackageDescription hiding (Flag) -- from Cabal+import qualified Distribution.PackageDescription as P -- from Cabal -import Distribution.Solver.Modular.Package import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath  -- | Flag name. Consists of a package instance and the flag identifier itself.-data FN qpn = FN (PI qpn) Flag+data FN qpn = FN qpn Flag   deriving (Eq, Ord, Show, Functor)  -- | Flag identifier. Just a string.-type Flag = FlagName+type Flag = P.FlagName +-- | Stanza identifier.+type Stanza = OptionalStanza+ unFlag :: Flag -> String-unFlag = unFlagName+unFlag = P.unFlagName  mkFlag :: String -> Flag-mkFlag = mkFlagName+mkFlag = P.mkFlagName  -- | Flag info. Default value, whether the flag is manual, and -- whether the flag is weak. Manual flags can only be set explicitly.@@ -52,7 +57,7 @@ type QFN = FN QPN  -- | Stanza name. Paired with a package name, much like a flag.-data SN qpn = SN (PI qpn) OptionalStanza+data SN qpn = SN qpn Stanza   deriving (Eq, Ord, Show, Functor)  -- | Qualified stanza name.@@ -72,21 +77,32 @@ newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }   deriving (Eq, Ord, Show) +-- | Value shown for a flag in a solver log message. The message can refer to+-- only the true choice, only the false choice, or both choices.+data FlagValue = FlagTrue | FlagFalse | FlagBoth+  deriving (Eq, Show)+ showQFNBool :: QFN -> Bool -> String-showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b+showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b  showQSNBool :: QSN -> Bool -> String-showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b+showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b  showFBool :: FN qpn -> Bool -> String-showFBool (FN _ f) v = showFlagValue (f, v)+showFBool (FN _ f) v = P.showFlagValue (f, v) -showSBool :: SN qpn -> Bool -> String-showSBool (SN _ s) True  = "*" ++ showStanza s-showSBool (SN _ s) False = "!" ++ showStanza s+-- | String representation of a flag-value pair.+showFlagValue :: P.FlagName -> FlagValue -> String+showFlagValue f FlagTrue  = '+' : unFlag f+showFlagValue f FlagFalse = '-' : unFlag f+showFlagValue f FlagBoth  = "+/-" ++ unFlag f +showSBool :: Stanza -> Bool -> String+showSBool s True  = "*" ++ showStanza s+showSBool s False = "!" ++ showStanza s+ showQFN :: QFN -> String-showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f+showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f  showQSN :: QSN -> String-showQSN (SN pi s) = showPI pi ++ ":" ++ showStanza s+showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s

Distribution/Solver/Modular/Index.hs view

@@ -13,8 +13,7 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree--import Distribution.Solver.Types.ComponentDeps (Component)+import Distribution.Types.UnqualComponentName  -- | An index contains information about package instances. This is a nested -- dictionary. Package names are mapped to instances, which in turn is mapped@@ -22,13 +21,12 @@ type Index = Map PN (Map I PInfo)  -- | Info associated with a package instance.--- Currently, dependencies, flags and failure reasons.+-- Currently, dependencies, executable names, flags and failure reasons. -- Packages that have a failure reason recorded for them are disabled -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken.-data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason)-  deriving (Show)+data PInfo = PInfo (FlaggedDeps PN) [UnqualComponentName] FlagInfo (Maybe FailReason)  mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))@@ -42,9 +40,9 @@                               | -- Find all versions of base ..                                 Just is <- [M.lookup base idx]                                 -- .. which are installed ..-                              , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is+                              , (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is                                 -- .. and flatten all their dependencies ..-                              , (Dep _is_exe dep _ci, _comp) <- flattenFlaggedDeps deps+                              , (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps                               ]     , qoSetupIndependent = True     }

Distribution/Solver/Modular/IndexConversion.hs view

@@ -3,11 +3,11 @@     ) where  import Data.List as L-import Data.Map as M+import Distribution.Compat.Map.Strict (Map)+import qualified Distribution.Compat.Map.Strict as M import Data.Maybe import Data.Monoid as Mon import Data.Set as S-import Prelude hiding (pi)  import Distribution.Compiler import Distribution.InstalledPackageInfo as IPI@@ -55,8 +55,8 @@ -- explicitly requested. convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables ->            SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index-convPIs os arch comp sip strfl sexes iidx sidx =-  mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sexes sidx)+convPIs os arch comp sip strfl solveExes iidx sidx =+  mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl solveExes sidx)  -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver.@@ -72,8 +72,8 @@   where      -- shadowing is recorded in the package info-    shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))-    shadow x                                = x+    shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed))+    shadow x                                     = x  -- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I. convId :: InstalledPackageInfo -> (PN, I)@@ -85,15 +85,14 @@ -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi =-  case mapM (convIPId pn idx) (IPI.depends ipi) of-        Nothing  -> (pn, i, PInfo []            M.empty (Just Broken))-        Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing)+  case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of+        Nothing  -> (pn, i, PInfo [] [] M.empty (Just Broken))+        Just fds -> (pn, i, PInfo fds [] M.empty Nothing)  where   (pn, i) = convId ipi   -- 'sourceLibName' is unreliable, but for now we only really use this for   -- primary libs anyways-  setComp = setCompFlaggedDeps $ componentNameToComponent-    $ libraryComponentName $ sourceLibName ipi+  comp = componentNameToComponent $ libraryComponentName $ sourceLibName ipi -- TODO: Installed packages should also store their encapsulations!  -- Note [Index conversion with internal libraries]@@ -129,12 +128,12 @@ -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored.-convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN)-convIPId pn' idx ipid =+convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep PN)+convIPId dr comp idx ipid =   case SI.lookupUnitId idx ipid of     Nothing  -> Nothing     Just ipi -> let (pn, i) = convId ipi-                in  Just (D.Simple (Dep False pn (Fixed i (P pn'))) ())+                in  Just (D.Simple (LDep dr (Dep Nothing pn (Fixed i))) comp)                 -- NB: something we pick up from the                 -- InstalledPackageIndex is NEVER an executable @@ -142,13 +141,13 @@ -- more uniform index format of the solver. convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables ->             CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]-convSPI' os arch cinfo strfl sexes = L.map (convSP os arch cinfo strfl sexes) . CI.allPackages+convSPI' os arch cinfo strfl solveExes = L.map (convSP os arch cinfo strfl solveExes) . CI.allPackages  -- | Convert a single source package into the solver-specific format. convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)-convSP os arch cinfo strfl sexes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =+convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =   let i = I pv InRepo-  in  (pn, i, convGPD os arch cinfo strfl sexes (PI pn i) gpd)+  in  (pn, i, convGPD os arch cinfo strfl solveExes pn gpd)  -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we@@ -156,8 +155,8 @@  -- | Convert a generic package description to a solver-specific 'PInfo'. convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables ->-           PI PN -> GenericPackageDescription -> PInfo-convGPD os arch cinfo strfl sexes pi+           PN -> GenericPackageDescription -> PInfo+convGPD os arch cinfo strfl solveExes pn         (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) =   let     fds  = flagInfo strfl flags@@ -171,22 +170,30 @@     ipns = S.fromList $ [ unqualComponentNameToPackageName nm                         | (nm, _) <- sub_libs ] -    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) ->-            CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN-    conv comp getInfo = convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes .-                        PDC.addBuildableCondition getInfo+    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->+            CondTree ConfVar [Dependency] a -> FlaggedDeps PN+    conv comp getInfo dr =+        convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo ipns solveExes .+        PDC.addBuildableCondition getInfo +    initDR = DependencyReason pn M.empty S.empty+     flagged_deps-        = concatMap (\ds -> conv ComponentLib libBuildInfo ds) (maybeToList mlib)-       ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm)   libBuildInfo       ds) sub_libs-       ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm)  foreignLibBuildInfo ds) flibs-       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)   buildInfo          ds) exes-       ++ prefix (Stanza (SN pi TestStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentTest nm)  testBuildInfo      ds) tests)-       ++ prefix (Stanza (SN pi BenchStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs)-       ++ maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)+        = concatMap (\ds ->       conv ComponentLib         libBuildInfo        initDR ds) (maybeToList mlib)+       ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo        initDR ds) sub_libs+       ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm)   foreignLibBuildInfo initDR ds) flibs+       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)    buildInfo           initDR ds) exes+       ++ prefix (Stanza (SN pn TestStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentTest nm)   testBuildInfo (addStanza TestStanzas initDR) ds)+                    tests)+       ++ prefix (Stanza (SN pn BenchStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentBench nm)  benchmarkBuildInfo (addStanza BenchStanzas initDR) ds)+                    benchs)+       ++ maybe []  (convSetupBuildInfo pn) (setupBuildInfo pkg) +    addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn+    addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss)+     -- | We infer the maximally supported spec-version from @lib:Cabal@'s version     --     -- As we cannot predict the future, we can only properly support@@ -216,13 +223,13 @@     fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer)        | otherwise               = Nothing   in-    PInfo flagged_deps fds fr+    PInfo flagged_deps (L.map fst exes) fds fr  -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be -- something like @Stanza sn@).-prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn)-       -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn+prefix :: (FlaggedDeps qpn -> FlaggedDep qpn)+       -> [FlaggedDeps qpn] -> FlaggedDeps qpn prefix _ []  = [] prefix f fds = [f (concat fds)] @@ -239,43 +246,100 @@ -- dependencies. type IPNs = Set PN --- | Convenience function to delete a 'FlaggedDep' if it's+-- | Convenience function to delete a 'Dependency' if it's -- for a 'PN' that isn't actually real.-filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN-filterIPNs ipns (Dependency pn _) fd-    | S.notMember pn ipns = [fd]-    | otherwise           = []+filterIPNs :: IPNs -> Dependency -> Maybe Dependency+filterIPNs ipns d@(Dependency pn _)+    | S.notMember pn ipns = Just d+    | otherwise           = Nothing  -- | Convert condition trees to flagged dependencies.  Mutually -- recursive with 'convBranch'.  See 'convBranch' for an explanation -- of all arguments preceeding the input 'CondTree'.-convCondTree :: PackageDescription -> OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->+convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo ->                 Component ->                 (a -> BuildInfo) ->                 IPNs ->                 SolveExecutables ->-                CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN-convCondTree pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes@(SolveExecutables sexes') (CondNode info ds branches) =-                 concatMap-                    (\d -> filterIPNs ipns d (D.Simple (convLibDep pn d) comp))-                    ds  -- unconditional package dependencies-              ++ L.map (\e -> D.Simple (Ext  e) comp) (PD.allExtensions bi) -- unconditional extension dependencies-              ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages  bi) -- unconditional language dependencies-              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies-              ++ concatMap (convBranch pkg os arch cinfo pi fds comp getInfo ipns sexes) branches+                CondTree ConfVar [Dependency] a -> FlaggedDeps PN+convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =+             -- Merge all library and build-tool dependencies at every level in+             -- the tree of flagged dependencies. Otherwise 'extractCommon'+             -- could create duplicate dependencies, and the number of+             -- duplicates could grow exponentially from the leaves to the root+             -- of the tree.+             mergeSimpleDeps $+                 L.map (\d -> D.Simple (convLibDep dr d) comp)+                       (mapMaybe (filterIPNs ipns) ds)                                -- unconditional package dependencies+              ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (PD.allExtensions bi) -- unconditional extension dependencies+              ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (PD.allLanguages  bi) -- unconditional language dependencies+              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies+              ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes) branches               -- build-tools dependencies               -- NB: Only include these dependencies if SolveExecutables               -- is True.  It might be false in the legacy solver               -- codepath, in which case there won't be any record of               -- an executable we need.-              ++ [ D.Simple (convExeDep pn exeDep) comp-                 | sexes'+              ++ [ D.Simple (convExeDep dr exeDep) comp+                 | solveExes'                  , exeDep <- getAllToolDependencies pkg bi                  , not $ isInternal pkg exeDep                  ]   where     bi = getInfo info +data SimpleFlaggedDepKey qpn =+    SimpleFlaggedDepKey (Maybe UnqualComponentName) qpn Component+  deriving (Eq, Ord)++data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR++-- | Merge 'Simple' dependencies that apply to the same library or build-tool.+-- This function should be able to merge any two dependencies that can be merged+-- by extractCommon, in order to prevent the exponential growth of dependencies.+--+-- Note that this function can merge dependencies that have different+-- DependencyReasons, which can make the DependencyReasons less precise. This+-- loss of precision only affects performance and log messages, not correctness.+-- However, when 'mergeSimpleDeps' is only called on dependencies at a single+-- location in the dependency tree, the only difference between+-- DependencyReasons should be flags that have value FlagBoth. Adding extra+-- flags with value FlagBoth should not affect performance, since they are not+-- added to the conflict set. The only downside is the possibility of the log+-- incorrectly saying that the flag contributed to excluding a specific version+-- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB+-- introduces pkg <5, the merged dependency would mean that+-- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply+-- that +/-flagA excludes pkg-6.+mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn+mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged+  where+    (merged, unmerged) = L.foldl' f (M.empty, []) deps+      where+        f :: Ord qpn+          => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)+          -> FlaggedDep qpn+          -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)+        f (merged', unmerged') (D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp) =+            ( M.insertWith mergeValues+                           (SimpleFlaggedDepKey mExe qpn comp)+                           (SimpleFlaggedDepValue dr vr)+                           merged'+            , unmerged')+        f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged')++        mergeValues :: SimpleFlaggedDepValue qpn+                    -> SimpleFlaggedDepValue qpn+                    -> SimpleFlaggedDepValue qpn+        mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) =+            SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2)++    toFlaggedDep :: SimpleFlaggedDepKey qpn+                 -> SimpleFlaggedDepValue qpn+                 -> FlaggedDep qpn+    toFlaggedDep (SimpleFlaggedDepKey mExe qpn comp) (SimpleFlaggedDepValue dr vr) =+        D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp+ -- | Branch interpreter.  Mutually recursive with 'convCondTree'. -- -- Here, we try to simplify one of Cabal's condition tree branches into the@@ -287,46 +351,81 @@ -- -- This function takes a number of arguments: -----      1. Some pre dependency-solving known information ('OS', 'Arch',+--      1. A map of flag values that have already been chosen. It allows+--         convBranch to avoid creating nested FlaggedDeps that are+--         controlled by the same flag and avoid creating DependencyReasons with+--         conflicting values for the same flag.+--+--      2. The DependencyReason calculated at this point in the tree of+--         conditionals. The flag values in the DependencyReason are similar to+--         the values in the map above, except for the use of FlagBoth.+--+--      3. Some pre dependency-solving known information ('OS', 'Arch', --         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, -----      2. The package instance @'PI' 'PN'@ which this condition tree+--      4. The package name @'PN'@ which this condition tree --         came from, so that we can correctly associate @flag()@ --         variables with the correct package name qualifier, -----      3. The flag defaults 'FlagInfo' so that we can populate+--      5. The flag defaults 'FlagInfo' so that we can populate --         'Flagged' dependencies with 'FInfo', -----      4. The name of the component 'Component' so we can record where+--      6. The name of the component 'Component' so we can record where --         the fine-grained information about where the component came --         from (see 'convCondTree'), and -----      5. A selector to extract the 'BuildInfo' from the leaves of+--      7. A selector to extract the 'BuildInfo' from the leaves of --         the 'CondTree' (which actually contains the needed --         dependency information.) -----      6. The set of package names which should be considered internal+--      8. The set of package names which should be considered internal --         dependencies, and thus not handled as dependencies.-convBranch :: PackageDescription -> OS -> Arch -> CompilerInfo ->-              PI PN -> FlagInfo ->-              Component ->-              (a -> BuildInfo) ->-              IPNs ->-              SolveExecutables ->-              CondBranch ConfVar [Dependency] a ->-              FlaggedDeps Component PN-convBranch pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (CondBranch c' t' mf') =-  go c' (          convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes  t')-        (maybe [] (convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes) mf')+convBranch :: Map FlagName Bool+           -> DependencyReason PN+           -> PackageDescription+           -> OS+           -> Arch+           -> CompilerInfo+           -> PN+           -> FlagInfo+           -> Component+           -> (a -> BuildInfo)+           -> IPNs+           -> SolveExecutables+           -> CondBranch ConfVar [Dependency] a+           -> FlaggedDeps PN+convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') =+    go c'+       (\flags' dr' ->           convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes  t')+       (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes) mf')+       flags dr   where-    go :: Condition ConfVar ->-          FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN+    go :: Condition ConfVar+       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)+       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)+       ->  Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN     go (Lit True)  t _ = t     go (Lit False) _ f = f     go (CNot c)    t f = go c f t     go (CAnd c d)  t f = go c (go d t f) f     go (COr  c d)  t f = go c t (go d t f)-    go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f]+    go (Var (Flag fn)) t f = \flags' ->+        case M.lookup fn flags' of+          Just True  -> t flags'+          Just False -> f flags'+          Nothing    -> \dr' ->+            -- Add each flag to the DependencyReason for all dependencies below,+            -- including any extracted dependencies. Extracted dependencies are+            -- introduced by both flag values (FlagBoth). Note that we don't+            -- actually need to add the flag to the extracted dependencies for+            -- correct backjumping; the information only improves log messages+            -- by giving the user the full reason for each dependency.+            let addFlagValue v = addFlagToDependencyReason fn v dr'+                addFlag v = M.insert fn v flags'+            in extractCommon (t (addFlag True)  (addFlagValue FlagBoth))+                             (f (addFlag False) (addFlagValue FlagBoth))+                ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True)  (addFlagValue FlagTrue))+                                                     (f (addFlag False) (addFlagValue FlagFalse)) ]     go (Var (OS os')) t f       | os == os'      = t       | otherwise      = f@@ -344,36 +443,48 @@       where         matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv +    addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn+    addFlagToDependencyReason fn v (DependencyReason pn' fs ss) =+        DependencyReason pn' (M.insert fn v fs) ss+     -- If both branches contain the same package as a simple dep, we lift it to-    -- the next higher-level, but without constraints. This heuristic together-    -- with deferring flag choices will then usually first resolve this package,-    -- and try an already installed version before imposing a default flag choice-    -- that might not be what we want.+    -- the next higher-level, but with the union of version ranges. This+    -- heuristic together with deferring flag choices will then usually first+    -- resolve this package, and try an already installed version before imposing+    -- a default flag choice that might not be what we want.     --     -- Note that we make assumptions here on the form of the dependencies that-    -- can occur at this point. In particular, no occurrences of Fixed, and no-    -- occurrences of multiple version ranges, as all dependencies below this-    -- point have been generated using 'convLibDep'.+    -- can occur at this point. In particular, no occurrences of Fixed, as all+    -- dependencies below this point have been generated using 'convLibDep'.     --     -- WARNING: This is quadratic!-    extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN-    extractCommon ps ps' = [ D.Simple (Dep is_exe1 pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp-                           | D.Simple (Dep is_exe1 pn1 (Constrained [(vr1, _)])) _ <- ps-                           , D.Simple (Dep is_exe2 pn2 (Constrained [(vr2, _)])) _ <- ps'-                           , pn1 == pn2-                           , is_exe1 == is_exe2-                           ]+    extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn+    extractCommon ps ps' =+        -- Union the DependencyReasons, because the extracted dependency can be+        -- avoided by removing the dependency from either side of the+        -- conditional.+        [ D.Simple (LDep (unionDRs vs1 vs2) (Dep mExe1 pn1 (Constrained $ vr1 .||. vr2))) comp+        | D.Simple (LDep vs1                (Dep mExe1 pn1 (Constrained vr1))) _ <- ps+        , D.Simple (LDep vs2                (Dep mExe2 pn2 (Constrained vr2))) _ <- ps'+        , pn1 == pn2+        , mExe1 == mExe2+        ] +-- | Merge DependencyReasons by unioning their variables.+unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn+unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =+    DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2)+ -- | Convert a Cabal dependency on a library to a solver-specific dependency.-convLibDep :: PN -> Dependency -> Dep PN-convLibDep pn' (Dependency pn vr) = Dep False {- not exe -} pn (Constrained [(vr, P pn')])+convLibDep :: DependencyReason PN -> Dependency -> LDep PN+convLibDep dr (Dependency pn vr) = LDep dr $ Dep Nothing pn (Constrained vr) --- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency.--- TODO do something about the name of the exe component itself-convExeDep :: PN -> ExeDependency -> Dep PN-convExeDep pn' (ExeDependency pn _ vr) = Dep True pn (Constrained [(vr, P pn')])+-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.+convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN+convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr)  -- | Convert setup dependencies-convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN-convSetupBuildInfo (PI pn _i) nfo =-    L.map (\d -> D.Simple (convLibDep pn d) ComponentSetup) (PD.setupDepends nfo)+convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN+convSetupBuildInfo pn nfo =+    L.map (\d -> D.Simple (convLibDep (DependencyReason pn M.empty S.empty) d) ComponentSetup)+          (PD.setupDepends nfo)

Distribution/Solver/Modular/LabeledGraph.hs view

@@ -49,7 +49,7 @@     max_v        = length edges0 - 1     bounds0      = (0, max_v) :: (Vertex, Vertex)     sorted_edges = sortBy lt edges0-    edges1       = zipWith (,) [0..] sorted_edges+    edges1       = zip [0..] sorted_edges      graph        = array bounds0 [(v, (mapMaybe mk_edge ks))                                  | (v, (_, _, ks)) <- edges1]

Distribution/Solver/Modular/Linking.hs view

@@ -5,11 +5,12 @@   ) where  import Prelude ()-import Distribution.Client.Compat.Prelude hiding (get,put)+import Distribution.Solver.Compat.Prelude hiding (get,put)  import Control.Exception (assert) import Control.Monad.Reader import Control.Monad.State+import Data.Function (on) import Data.Map ((!)) import Data.Set (Set) import qualified Data.Map         as M@@ -28,7 +29,6 @@  import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Types.GenericPackageDescription (unFlagName)  {-------------------------------------------------------------------------------@@ -59,8 +59,13 @@     , vsFlags    :: FAssignment     , vsStanzas  :: SAssignment     , vsQualifyOptions :: QualifyOptions++    -- Saved qualified dependencies. Every time 'validateLinking' makes a+    -- package choice, it qualifies the package's dependencies and saves them in+    -- this map. Then the qualified dependencies are available for subsequent+    -- flag and stanza choices for the same package.+    , vsSaved    :: Map QPN (FlaggedDeps QPN)     }-    deriving Show  type Validate = Reader ValidateState @@ -92,11 +97,12 @@     goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)     goP qpn@(Q _pp pn) opt@(POption i _) r = do       vs <- ask-      let PInfo deps _ _ = vsIndex vs ! pn ! i-          qdeps          = qualifyDeps (vsQualifyOptions vs) qpn deps+      let PInfo deps _ _ _ = vsIndex vs ! pn ! i+          qdeps            = qualifyDeps (vsQualifyOptions vs) qpn deps+          newSaved         = M.insert qpn qdeps (vsSaved vs)       case execUpdateState (pickPOption qpn opt qdeps) vs of         Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r+        Right vs'       -> local (const vs' { vsSaved = newSaved }) r      -- Flag choices     goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)@@ -121,6 +127,7 @@       , vsFlags   = M.empty       , vsStanzas = M.empty       , vsQualifyOptions = defaultQualifyOptions index+      , vsSaved   = M.empty       }  {-------------------------------------------------------------------------------@@ -149,7 +156,7 @@ execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState execUpdateState = execStateT . unUpdateState -pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState ()+pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps @@ -167,7 +174,7 @@       Just lg ->         makeCanonical lg qpn i -pickLink :: QPN -> I -> PackagePath -> FlaggedDeps Component QPN -> UpdateState ()+pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () pickLink qpn@(Q _pp pn) i pp' deps = do     vs <- get @@ -195,11 +202,11 @@     assert (sanityCheck (lgCanon lgTarget)) $ return ()      -- Merge the two link groups (updateLinkGroup will propagate the change)-    lgTarget' <- lift' $ lgMerge [] lgSource lgTarget+    lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget     updateLinkGroup lgTarget'      -- Make sure all dependencies are linked as well-    linkDeps target [P qpn] deps+    linkDeps target deps  makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () makeCanonical lg qpn@(Q pp _) i =@@ -223,47 +230,47 @@ -- because having the direct dependencies in a link group means that we must -- have already made or will make sooner or later a link choice for one of these -- as well, and cover their dependencies at that point.-linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState ()-linkDeps target = \blame deps -> do+linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()+linkDeps target = \deps -> do     -- linkDeps is called in two places: when we first link one package to     -- another, and when we discover more dependencies of an already linked     -- package after doing some flag assignment. It is therefore important that     -- flag assignments cannot influence _how_ dependencies are qualified;     -- fortunately this is a documented property of 'qualifyDeps'.     rdeps <- requalify deps-    go blame deps rdeps+    go deps rdeps   where-    go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState ()-    go = zipWithM_ . go1+    go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()+    go = zipWithM_ go1 -    go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState ()-    go1 blame dep rdep = case (dep, rdep) of-      (Simple (Dep _ qpn _) _, ~(Simple (Dep _ qpn' _) _)) -> do+    go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()+    go1 dep rdep = case (dep, rdep) of+      (Simple (LDep dr1 (Dep _ qpn _)) _, ~(Simple (LDep dr2 (Dep _ qpn' _)) _)) -> do         vs <- get         let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs             lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs-        lg'' <- lift' $ lgMerge blame lg lg'+        lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToCS) dr1 dr2) lg lg'         updateLinkGroup lg''       (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do         vs <- get         case M.lookup fn (vsFlags vs) of           Nothing    -> return () -- flag assignment not yet known-          Just True  -> go (F fn:blame) t t'-          Just False -> go (F fn:blame) f f'+          Just True  -> go t t'+          Just False -> go f f'       (Stanza sn t, ~(Stanza _ t')) -> do         vs <- get         case M.lookup sn (vsStanzas vs) of           Nothing    -> return () -- stanza assignment not yet known-          Just True  -> go (S sn:blame) t t'+          Just True  -> go t t'           Just False -> return () -- stanza not enabled; no new deps     -- For extensions and language dependencies, there is nothing to do.     -- No choice is involved, just checking, so there is nothing to link.     -- The same goes for for pkg-config constraints.-      (Simple (Ext  _)   _, _) -> return ()-      (Simple (Lang _)   _, _) -> return ()-      (Simple (Pkg  _ _) _, _) -> return ()+      (Simple (LDep _ (Ext  _))   _, _) -> return ()+      (Simple (LDep _ (Lang _))   _, _) -> return ()+      (Simple (LDep _ (Pkg  _ _)) _, _) -> return () -    requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN)+    requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)     requalify deps = do       vs <- get       return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)@@ -280,7 +287,7 @@     verifyStanza qsn     linkNewDeps (S qsn) b --- | Link dependencies that we discover after making a flag choice.+-- | Link dependencies that we discover after making a flag or stanza choice. -- -- When we make a flag choice for a package, then new dependencies for that -- package might become available. If the package under consideration is in a@@ -290,31 +297,28 @@ linkNewDeps :: Var QPN -> Bool -> UpdateState () linkNewDeps var b = do     vs <- get-    let (qpn@(Q pp pn), Just i) = varPI var-        PInfo deps _ _          = vsIndex vs ! pn ! i-        qdeps                   = qualifyDeps (vsQualifyOptions vs) qpn deps+    let qpn@(Q pp pn)           = varPN var+        qdeps                   = vsSaved vs ! qpn         lg                      = vsLinks vs ! qpn-        (parents, newDeps)      = findNewDeps vs qdeps+        newDeps                 = findNewDeps vs qdeps         linkedTo                = S.delete pp (lgMembers lg)-    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps+    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps   where-    findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)-    findNewDeps vs = concatMapUnzip (findNewDeps' vs)+    findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN+    findNewDeps vs = concatMap (findNewDeps' vs) -    findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)-    findNewDeps' _  (Simple _ _)        = ([], [])+    findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN+    findNewDeps' _  (Simple _ _)        = []     findNewDeps' vs (Flagged qfn _ t f) =       case (F qfn == var, M.lookup qfn (vsFlags vs)) of-        (True, _)    -> ([F qfn], if b then t else f)-        (_, Nothing) -> ([], []) -- not yet known-        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f)-                        in (F qfn:parents, deps)+        (True, _)    -> if b then t else f+        (_, Nothing) -> [] -- not yet known+        (_, Just b') -> findNewDeps vs (if b' then t else f)     findNewDeps' vs (Stanza qsn t) =       case (S qsn == var, M.lookup qsn (vsStanzas vs)) of-        (True, _)    -> ([S qsn], if b then t else [])-        (_, Nothing) -> ([], []) -- not yet known-        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else [])-                        in (S qsn:parents, deps)+        (True, _)    -> if b then t else []+        (_, Nothing) -> [] -- not yet known+        (_, Just b') -> findNewDeps vs (if b' then t else [])  updateLinkGroup :: LinkGroup -> UpdateState () updateLinkGroup lg = do@@ -342,27 +346,27 @@       -- if a constructor is added to the datatype we won't notice it here       Just i -> do         vs <- get-        let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i+        let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i             flags   = M.keys finfo             stanzas = [TestStanzas, BenchStanzas]         forM_ flags $ \fn -> do-          let flag = FN (PI (lgPackage lg) i) fn+          let flag = FN (lgPackage lg) fn           verifyFlag' flag lg         forM_ stanzas $ \sn -> do-          let stanza = SN (PI (lgPackage lg) i) sn+          let stanza = SN (lgPackage lg) sn           verifyStanza' stanza lg  verifyFlag :: QFN -> UpdateState ()-verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do+verifyFlag (FN qpn@(Q _pp pn) fn) = do     vs <- get     -- We can only pick a flag after picking an instance; link group must exist-    verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)+    verifyFlag' (FN pn fn) (vsLinks vs ! qpn)  verifyStanza :: QSN -> UpdateState ()-verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do+verifyStanza (SN qpn@(Q _pp pn) sn) = do     vs <- get     -- We can only pick a stanza after picking an instance; link group must exist-    verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn)+    verifyStanza' (SN pn sn) (vsLinks vs ! qpn)  -- | Verify that all packages in the link group agree on flag assignments --@@ -370,9 +374,9 @@ -- that have already been made for link group members, and check that they are -- equal. verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()-verifyFlag' (FN (PI pn i) fn) lg = do+verifyFlag' (FN pn fn) lg = do     vs <- get-    let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg))+    let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg))         vals  = map (`M.lookup` vsFlags vs) flags     if allEqual (catMaybes vals) -- We ignore not-yet assigned flags       then return ()@@ -388,9 +392,9 @@ -- -- This function closely mirrors 'verifyFlag''. verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()-verifyStanza' (SN (PI pn i) sn) lg = do+verifyStanza' (SN pn sn) lg = do     vs <- get-    let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg))+    let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg))         vals    = map (`M.lookup` vsStanzas vs) stanzas     if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas       then return ()@@ -472,14 +476,14 @@     , lgBlame   = CS.empty     } -lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup+lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup lgMerge blame lg lg' = do     canon <- pick (lgCanon lg) (lgCanon lg')     return LinkGroup {         lgPackage = lgPackage lg       , lgCanon   = canon       , lgMembers = lgMembers lg `S.union` lgMembers lg'-      , lgBlame   = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg']+      , lgBlame   = CS.unions [blame, lgBlame lg, lgBlame lg']       }   where     pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)@@ -489,7 +493,7 @@     pick (Just x) (Just y) =       if x == y then Right $ Just x                 else Left ( CS.unions [-                               CS.fromList blame+                               blame                              , lgConflictSet lg                              , lgConflictSet lg'                              ]@@ -512,6 +516,3 @@ allEqual []       = True allEqual [_]      = True allEqual (x:y:ys) = x == y && allEqual (y:ys)--concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c])-concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f

Distribution/Solver/Modular/Log.hs view

@@ -1,12 +1,11 @@ module Distribution.Solver.Modular.Log     ( Log     , logToProgress+    , SolverFailure(..)     ) where  import Prelude ()-import Distribution.Client.Compat.Prelude--import Data.List as L+import Distribution.Solver.Compat.Prelude  import Distribution.Solver.Types.Progress @@ -23,20 +22,22 @@ -- Parameterized over the type of actual messages and the final result. type Log m a = Progress m (ConflictSet, ConflictMap) a -messages :: Progress step fail done -> [step]-messages = foldProgress (:) (const []) (const [])+data Exhaustiveness = Exhaustive | BackjumpLimit -data Exhaustiveness = Exhaustive | BackjumpLimitReached+-- | Information about a dependency solver failure. It includes an error message+-- and a final conflict set, if available.+data SolverFailure =+    NoSolution ConflictSet String+  | BackjumpLimitReached String  -- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. -- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the -- limit is 'Just 0', backtracking is completely disabled.-logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String String a+logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String SolverFailure a logToProgress verbosity mbj l =-    let es = proc (Just 0) l -- catch first error (always)-        ms = proc mbj l-    in go es es -- trace for first error-          (showMessages (const True) True ms) -- run with backjump limit applied+    let ms = proc mbj l+        mapFailure f = foldProgress Step (Fail . f) Done+    in mapFailure finalError (showMessages ms) -- run with backjump limit applied   where     -- Proc takes the allowed number of backjumps and a 'Progress' and explores the     -- messages until the maximum number of backjumps has been reached. It filters out@@ -48,30 +49,15 @@     proc _        (Fail (cs, cm))                   = Fail (Exhaustive, cs, cm)     proc mbj'     (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))       | cs == cs'                                   = Step x (proc mbj'           xs) -- repeated backjumps count as one-    proc (Just 0) (Step   (Failure cs Backjump)  _) = Fail (BackjumpLimitReached, cs, mempty) -- No final conflict map available+    proc (Just 0) (Step   (Failure cs Backjump)  _) = Fail (BackjumpLimit, cs, mempty) -- No final conflict map available     proc (Just n) (Step x@(Failure _  Backjump) xs) = Step x (proc (Just (n - 1)) xs)     proc mbj'     (Step x                       xs) = Step x (proc mbj'           xs) -    -- The first two arguments are both supposed to be the log up to the first error.-    -- That's the error that will always be printed in case we do not find a solution.-    -- We pass this log twice, because we evaluate it in parallel with the full log,-    -- but we also want to retain the reference to its beginning for when we print it.-    -- This trick prevents a space leak!-    ---    -- The third argument is the full log, ending with either the solution or the-    -- exhaustiveness and final conflict set.-    go :: Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b-       -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b-       -> Progress String  (Exhaustiveness, ConflictSet, ConflictMap) b-       -> Progress String String b-    go ms (Step _ ns)        (Step x xs)           = Step x (go ms ns xs)-    go ms r                  (Step x xs)           = Step x (go ms r  xs)-    go ms (Step _ ns)        r                     = go ms ns r-    go ms (Fail (_, cs', _)) (Fail (exh, cs, cm))  = Fail $-        "Could not resolve dependencies:\n" ++-        unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs') True) False ms) +++    finalError :: (Exhaustiveness, ConflictSet, ConflictMap) -> SolverFailure+    finalError (exh, cs, cm) =         case exh of             Exhaustive ->+                NoSolution cs $                 "After searching the rest of the dependency tree exhaustively, "                 ++ "these were the goals I've had most trouble fulfilling: "                 ++ showCS cm cs@@ -79,14 +65,9 @@                 showCS = if verbosity > normal                          then CS.showCSWithFrequency                          else CS.showCSSortedByFrequency-            BackjumpLimitReached ->+            BackjumpLimit ->+                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  = ""-    go _  _                  (Done s)              = Done s-    go _  (Done _)           (Fail _)              = Fail $-        -- Should not happen: Second argument is the log up to first error,-        -- third one is the entire log. Therefore it should never happen that-        -- the second log finishes with 'Done' and the third log with 'Fail'.-        "Could not resolve dependencies; something strange happened."

Distribution/Solver/Modular/Message.hs view

@@ -14,10 +14,12 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree-         ( FailReason(..), POption(..) )+         ( FailReason(..), POption(..), ConflictingDep(..) )+import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress+import Distribution.Types.UnqualComponentName  data Message =     Enter           -- ^ increase indentation level@@ -31,59 +33,46 @@  -- | Transforms the structured message type to actual messages (strings). ----- Takes an additional relevance predicate. The predicate gets a stack of goal--- variables and can decide whether messages regarding these goals are relevant.--- You can plug in 'const True' if you're interested in a full trace. If you--- want a slice of the trace concerning a particular conflict set, then plug in--- a predicate returning 'True' on the empty stack and if the head is in the--- conflict set.------ The second argument indicates if the level numbers should be shown. This is--- recommended for any trace that involves backtracking, because only the level--- numbers will allow to keep track of backjumps.-showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b-showMessages p sl = go [] 0+-- The log contains level numbers, which are useful for any trace that involves+-- backtracking, because only the level numbers will allow to keep track of+-- backjumps.+showMessages :: Progress Message a b -> Progress String a b+showMessages = go 0   where-    -- The stack 'v' represents variables that are currently assigned by the-    -- solver.  'go' pushes a variable for a recursive call when it encounters-    -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'.-    -- When 'go' processes a package goal, or a package goal followed by a-    -- 'Failure', it calls 'atLevel' with the goal variable at the head of the-    -- stack so that the predicate can also select messages relating to package-    -- goal choices.-    go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b-    go !_ !_ (Done x)                           = Done x-    go !_ !_ (Fail x)                           = Fail x+    -- 'go' increments the level for a recursive call when it encounters+    -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.+    go :: Int -> Progress Message a b -> Progress String a b+    go !_ (Done x)                           = Done x+    go !_ (Fail x)                           = Fail x     -- complex patterns-    go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        goPReject v l qpn [i] c fr ms-    go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)-    go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =-        (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) =-        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms+    go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        goPReject l qpn [i] c fr ms+    go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)+    go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (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@(Fail _)) =+        (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms         -- the previous case potentially arises in the error output, because we remove the backjump itself         -- if we cut the log after the first error-    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) =-        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms-    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =-        let v' = add (P qpn) v-        in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)-    go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))-        | c == c' = go v l ms+    go !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) =+        (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)+    go !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))+        | c == c' = go l ms     -- standard display-    go !v !l (Step Enter                    ms) = go v          (l+1) ms-    go !v !l (Step Leave                    ms) = go (drop 1 v) (l-1) ms-    go !v !l (Step (TryP qpn i)             ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)-    go !v !l (Step (TryF qfn b)             ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)-    go !v !l (Step (TryS qsn b)             ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)-    go !v !l (Step (Next _)                 ms) = go v l ms -- ignore flag goals in the log-    go !v !l (Step (Success)                ms) = (atLevel v l $ "done") (go v l ms)-    go !v !l (Step (Failure c fr)           ms) = (atLevel v l $ showFailure c fr) (go v l ms)+    go !l (Step Enter                    ms) = go (l+1) ms+    go !l (Step Leave                    ms) = go (l-1) ms+    go !l (Step (TryP qpn i)             ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)+    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)+    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)+    go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)+    go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log+    go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)+    go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms)      showPackageGoal :: QPN -> QGoalReason -> String     showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr@@ -91,30 +80,24 @@     showFailure :: ConflictSet -> FailReason -> String     showFailure c fr = "fail" ++ showFR c fr -    add :: Var QPN -> [Var QPN] -> [Var QPN]-    add v vs = simplifyVar v : vs-     -- special handler for many subsequent package rejections-    goPReject :: [Var QPN]-              -> Int+    goPReject :: Int               -> QPN               -> [POption]               -> ConflictSet               -> FailReason               -> Progress Message a b               -> Progress String a b-    goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))-      | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms-    goPReject v l qpn is c fr ms =-        (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)+    goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))+      | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms+    goPReject l qpn is c fr ms =+        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) -    -- write a message, but only if it's relevant; we can also enable or disable the display of the current level-    atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b-    atLevel v l x xs-      | sl && p v = let s = show l-                    in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs-      | p v       = Step x xs-      | otherwise = xs+    -- write a message with the current level number+    atLevel :: Int -> String -> Progress String a b -> Progress String a b+    atLevel l x xs =+      let s = show l+      in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs  showQPNPOpt :: QPN -> POption -> String showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =@@ -124,13 +107,16 @@  showGR :: QGoalReason -> String showGR UserGoal            = " (user goal)"-showGR (PDependency pi)    = " (dependency of " ++ showPI pi            ++ ")"-showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b    ++ ")"-showGR (SDependency qsn)   = " (dependency of " ++ showQSNBool qsn True ++ ")"+showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"  showFR :: ConflictSet -> FailReason -> String-showFR _ InconsistentInitialConstraints   = " (inconsistent initial constraints)"-showFR _ (Conflicting ds)                 = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"+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 _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"+showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"+showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")"+showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)" showFR _ CannotInstall                    = " (only already installed instances can be used)" showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)" showFR _ Shadowed                         = " (shadowed by another installed package with same version)"@@ -154,3 +140,15 @@  constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src++showConflictingDep :: ConflictingDep -> String+showConflictingDep (ConflictingDep dr mExe qpn ci) =+  let DependencyReason qpn' _ _ = dr+      exeStr = case mExe of+                 Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")"+                 Nothing  -> ""+  in case ci of+       Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") +++                         showQPN qpn ++ exeStr ++ "==" ++ showI i+       Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn +++                         exeStr ++ showVR vr

Distribution/Solver/Modular/PSQ.hs view

@@ -24,7 +24,6 @@     , snoc     , sortBy     , sortByKeys-    , splits     , toList     , union     ) where@@ -77,13 +76,6 @@   case xs of     []          -> n     (k, v) : ys -> c k v (PSQ ys)--splits :: PSQ k a -> PSQ k (a, PSQ k a)-splits = go id-  where-    go f xs = casePSQ xs-        (PSQ [])-        (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys))  sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)

Distribution/Solver/Modular/Package.hs view

@@ -101,9 +101,7 @@ setupPP (PackagePath _ns (QualSetup _)) = True setupPP (PackagePath _ns _)         = False --- | Create artificial parents for each of the package names, making--- them all independent.-makeIndependent :: [PN] -> [QPN]-makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]-                               , let pp = PackagePath (Independent i) QualToplevel-                     ]+-- | Qualify a target package with its own name so that its dependencies are not+-- required to be consistent with other targets.+makeIndependent :: PN -> QPN+makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn

Distribution/Solver/Modular/Preference.hs view

@@ -14,10 +14,11 @@     , preferReallyEasyGoalChoices     , requireInstalled     , sortGoals+    , pruneAfterFirstSuccess     ) where  import Prelude ()-import Distribution.Client.Compat.Prelude+import Distribution.Solver.Compat.Prelude  import Data.Function (on) import qualified Data.List as L@@ -25,6 +26,8 @@ import Control.Monad.Reader hiding (sequence) import Data.Traversable (sequence) +import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal+ import Distribution.Solver.Types.Flag import Distribution.Solver.Types.InstalledPreference import Distribution.Solver.Types.LabeledPackageConstraint@@ -128,7 +131,7 @@ preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c preferPackageStanzaPreferences pcs = trav go   where-    go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) rdm gr _tr ts)+    go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts)       | primaryPP pp && enableStanzaPref pn s =           -- move True case first to try enabling the stanza           let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts@@ -187,7 +190,7 @@   where     go :: PackageProperty -> Tree d c     go (PackagePropertyFlags fa) =-        case L.lookup f fa of+        case lookupFlagAssignment f fa of           Nothing            -> r           Just b | b == b'   -> r                  | otherwise -> Fail c (GlobalConstraintFlag src)@@ -230,14 +233,14 @@                                        id                                        (M.findWithDefault [] pn pcs)       in PChoiceF qpn rdm gr        (W.mapWithKey g ts)-    go (FChoiceF qfn@(FN (PI qpn@(Q _ pn) _) f) rdm gr tr m d ts) =+    go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) =       let c = varToConflictSet (F qfn)           -- compose the transformation functions for each of the relevant constraint           g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc)                            id                            (M.findWithDefault [] pn pcs)       in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts)-    go (SChoiceF qsn@(SN (PI qpn@(Q _ pn) _) f) rdm gr tr   ts) =+    go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr   ts) =       let c = varToConflictSet (S qsn)           -- compose the transformation functions for each of the relevant constraint           g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc)@@ -260,23 +263,25 @@ -- unconstrained goals to use the default value for x OR any of the values in -- the constraints on x (even though the constraints don't apply), in order to -- allow the unconstrained goals to be linked to the constrained goals. See--- https://github.com/haskell/cabal/issues/4299.+-- https://github.com/haskell/cabal/issues/4299. Removing the single instance+-- restriction (SIR) would also fix #4299, so we may want to remove this+-- exception and only let the user toggle manual flags if we remove the SIR. -- -- This function does not enforce any of the constraints, since that is done by -- 'enforcePackageConstraints'. enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c enforceManualFlags pcs = trav go   where-    go (FChoiceF qfn@(FN (PI (Q _ pn) _) fn) rdm gr tr Manual d ts) =+    go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) =         FChoiceF qfn rdm gr tr Manual d $-          let -- A list of all values specified by constraints on 'fn',-              -- regardless of scope.+          let -- A list of all values specified by constraints on 'fn'.+              -- We ignore the constraint scope in order to handle issue #4299.               flagConstraintValues :: [Bool]               flagConstraintValues =                   [ flagVal                   | let lpcs = M.findWithDefault [] pn pcs                   , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs-                  , (fn', flagVal) <- fa+                  , (fn', flagVal) <- unFlagAssignment fa                   , fn' == fn ]                -- Prune flag values that are not the default and do not match any@@ -344,8 +349,19 @@      varToVariable :: Var QPN -> Variable QPN     varToVariable (P qpn)                    = PackageVar qpn-    varToVariable (F (FN (PI qpn _) fn))     = FlagVar qpn fn-    varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza+    varToVariable (F (FN qpn fn))     = FlagVar qpn fn+    varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza++-- | Reduce the branching degree of the search tree by removing all choices+-- after the first successful choice at each level. The returned tree is the+-- minimal subtree containing the path to the first backjump.+pruneAfterFirstSuccess :: Tree d c -> Tree d c+pruneAfterFirstSuccess = trav go+  where+    go (PChoiceF qpn rdm gr       ts) = PChoiceF qpn rdm gr       (W.takeUntil active ts)+    go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts)+    go (SChoiceF qsn rdm gr w     ts) = SChoiceF qsn rdm gr w     (W.takeUntil active ts)+    go x                              = x  -- | Always choose the first goal in the list next, abandoning all -- other choices.

Distribution/Solver/Modular/Solver.hs view

@@ -6,13 +6,13 @@ module Distribution.Solver.Modular.Solver     ( SolverConfig(..)     , solve+    , PruneAfterFirstSuccess(..)     ) where  import Data.Map as M import Data.List as L import Data.Set as S import Distribution.Verbosity-import Distribution.Version  import Distribution.Compiler (CompilerInfo) @@ -42,7 +42,6 @@ import Distribution.Simple.Setup (BooleanFlag(..))  #ifdef DEBUG_TRACETREE-import Distribution.Solver.Modular.Flag import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W import qualified Distribution.Text as T@@ -55,20 +54,25 @@  -- | Various options for the modular solver. data SolverConfig = SolverConfig {-  reorderGoals          :: ReorderGoals,-  countConflicts        :: CountConflicts,-  independentGoals      :: IndependentGoals,-  avoidReinstalls       :: AvoidReinstalls,-  shadowPkgs            :: ShadowPkgs,-  strongFlags           :: StrongFlags,-  allowBootLibInstalls  :: AllowBootLibInstalls,-  maxBackjumps          :: Maybe Int,-  enableBackjumping     :: EnableBackjumping,-  solveExecutables      :: SolveExecutables,-  goalOrder             :: Maybe (Variable QPN -> Variable QPN -> Ordering),-  solverVerbosity       :: Verbosity+  reorderGoals           :: ReorderGoals,+  countConflicts         :: CountConflicts,+  independentGoals       :: IndependentGoals,+  avoidReinstalls        :: AvoidReinstalls,+  shadowPkgs             :: ShadowPkgs,+  strongFlags            :: StrongFlags,+  allowBootLibInstalls   :: AllowBootLibInstalls,+  maxBackjumps           :: Maybe Int,+  enableBackjumping      :: EnableBackjumping,+  solveExecutables       :: SolveExecutables,+  goalOrder              :: Maybe (Variable QPN -> Variable QPN -> Ordering),+  solverVerbosity        :: Verbosity,+  pruneAfterFirstSuccess :: PruneAfterFirstSuccess } +-- | Whether to remove all choices after the first successful choice at each+-- level in the search tree.+newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool+ -- | Run all solver phases. -- -- In principle, we have a valid tree after 'validationPhase', which@@ -99,15 +103,18 @@     detectCycles     = traceTree "cycles.json" id . detectCyclesPhase     heuristicsPhase  =       let heuristicsTree = traceTree "heuristics.json" id-      in case goalOrder sc of-           Nothing -> goalChoiceHeuristics .-                      heuristicsTree .-                      P.deferSetupChoices .-                      P.deferWeakFlagChoices .-                      P.preferBaseGoalChoice-           Just order -> P.firstGoal .-                         heuristicsTree .-                         P.sortGoals order+          sortGoals = case goalOrder sc of+                        Nothing -> goalChoiceHeuristics .+                                   heuristicsTree .+                                   P.deferSetupChoices .+                                   P.deferWeakFlagChoices .+                                   P.preferBaseGoalChoice+                        Just order -> P.firstGoal .+                                   heuristicsTree .+                                   P.sortGoals order+          PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc+      in sortGoals .+         (if prune then P.pruneAfterFirstSuccess else id)     preferencesPhase = P.preferLinked .                        P.preferPackagePreferences userPrefs     validationPhase  = traceTree "validated.json" id .@@ -202,10 +209,8 @@       -- to know the variable that introduced the goal, not the value assigned       -- to that variable)       shortGR :: QGoalReason -> String-      shortGR UserGoal               = "user"-      shortGR (PDependency (PI nm _)) = showQPN nm-      shortGR (FDependency nm _)      = showQFN nm-      shortGR (SDependency nm)        = showQSN nm+      shortGR UserGoal            = "user"+      shortGR (DependencyGoal dr) = showDependencyReason dr        -- Show conflict set       goCS :: ConflictSet -> String@@ -232,6 +237,8 @@        . PSQ.toList     dummy :: QGoalReason-   dummy = PDependency-         $ PI (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))-              (I (mkVersion [1]) InRepo)+   dummy =+       DependencyGoal $+       DependencyReason+           (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))+           M.empty S.empty

Distribution/Solver/Modular/Tree.hs view

@@ -1,10 +1,11 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Distribution.Solver.Modular.Tree-    ( FailReason(..)-    , POption(..)+    ( POption(..)     , Tree(..)     , TreeF(..)     , Weight+    , FailReason(..)+    , ConflictingDep(..)     , ana     , cata     , inn@@ -12,6 +13,7 @@     , para     , trav     , zeroOrOneChoices+    , active     ) where  import Control.Monad hiding (mapM, sequence)@@ -29,6 +31,8 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath+import Distribution.Types.UnqualComponentName+import Language.Haskell.Extension (Extension, Language)  type Weight = Double @@ -72,7 +76,6 @@      -- | We failed to find a solution in this path through the tree   | Fail ConflictSet FailReason-  deriving (Eq, Show)  -- | A package option is a package instance with an optional linking annotation --@@ -93,8 +96,13 @@ data POption = POption I (Maybe PackagePath)   deriving (Eq, Show) -data FailReason = InconsistentInitialConstraints-                | Conflicting [Dep QPN]+data FailReason = UnsupportedExtension Extension+                | UnsupportedLanguage Language+                | MissingPkgconfigPackage PkgconfigName VR+                | NewPackageDoesNotMatchExistingConstraint ConflictingDep+                | ConflictingConstraints ConflictingDep ConflictingDep+                | NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN)+                | PackageRequiresMissingExe QPN UnqualComponentName                 | CannotInstall                 | CannotReinstall                 | Shadowed@@ -112,6 +120,10 @@                 | DependenciesNotLinked String                 | CyclicDependencies                 | UnsupportedSpecVer Ver+  deriving (Eq, Show)++-- | Information about a dependency involved in a conflict, for error messages.+data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI   deriving (Eq, Show)  -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'

Distribution/Solver/Modular/Validate.hs view

@@ -1,5 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+#ifdef DEBUG_CONFLICT_SETS+{-# LANGUAGE ImplicitParams #-}+#endif module Distribution.Solver.Modular.Validate (validateTree) where  -- Validation of the tree.@@ -10,30 +14,35 @@  import Control.Applicative import Control.Monad.Reader hiding (sequence)+import Data.Function (on) import Data.List as L-import Data.Map as M import Data.Set as S import Data.Traversable import Prelude hiding (sequence)  import Language.Haskell.Extension (Extension, Language) +import Distribution.Compat.Map.Strict as M import Distribution.Compiler (CompilerInfo(..))  import Distribution.Solver.Modular.Assignment+import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version (VR)+import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ComponentDeps (Component)- import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)+import Distribution.Types.UnqualComponentName +#ifdef DEBUG_CONFLICT_SETS+import GHC.Stack (CallStack)+#endif+ -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints -- that for which the preconditions are fulfilled ACTIVE. We maintain a set@@ -90,8 +99,23 @@   supportedLang :: Language  -> Bool,   presentPkgs   :: PkgconfigName -> VR  -> Bool,   index :: Index,-  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies++  -- Saved, scoped, dependencies. Every time 'validate' makes a package choice,+  -- it qualifies the package's dependencies and saves them in this map. Then+  -- the qualified dependencies are available for subsequent flag and stanza+  -- choices for the same package.+  saved :: Map QPN (FlaggedDeps QPN),+   pa    :: PreAssignment,++  -- Map from package name to the executables that are provided by the chosen+  -- instance of that package.+  availableExes  :: Map QPN [UnqualComponentName],++  -- Map from package name to the executables that are required from that+  -- package.+  requiredExes   :: Map QPN ExeDeps,+   qualifyOptions :: QualifyOptions } @@ -101,6 +125,40 @@ runValidate :: Validate a -> ValidateState -> a runValidate (Validate r) = runReader r +-- | A preassignment comprises knowledge about variables, but not+-- necessarily fixed values.+data PreAssignment = PA PPreAssignment FAssignment SAssignment++-- | A (partial) package preassignment. Qualified package names+-- are associated with MergedPkgDeps.+type PPreAssignment = Map QPN MergedPkgDep++-- | A dependency on a package, including its DependencyReason.+data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI++-- | Map from executable name to one of the reasons that the executable is+-- required.+type ExeDeps = Map UnqualComponentName (DependencyReason QPN)++-- | MergedPkgDep records constraints about the instances that can still be+-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a+-- list of version ranges paired with the goals / variables that introduced+-- them. It also records whether a package is a build-tool dependency, for each+-- reason that it was introduced.+--+-- It is important to store the executable name with the version constraint, for+-- error messages, because whether something is a build-tool dependency affects+-- its qualifier, which affects which constraint is applied.+data MergedPkgDep =+    MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I+  | MergedDepConstrained [VROrigin]++-- | Version ranges paired with origins.+type VROrigin = (VR, Maybe UnqualComponentName, DependencyReason QPN)++-- | The information needed to create a 'Fail' node.+type Conflict = (ConflictSet, FailReason)+ validate :: Tree d c -> Validate (Tree d c) validate = cata go   where@@ -146,36 +204,51 @@       pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs       idx            <- asks index -- obtain the index       svd            <- asks saved -- obtain saved dependencies+      aExes          <- asks availableExes+      rExes          <- asks requiredExes       qo             <- asks qualifyOptions       -- obtain dependencies and index-dictated exclusions introduced by the choice-      let (PInfo deps _ mfr) = idx ! pn ! i+      let (PInfo deps exes _ mfr) = idx ! pn ! i       -- qualify the deps in the current scope       let qdeps = qualifyDeps qo qpn deps       -- the new active constraints are given by the instance we have chosen,       -- plus the dependency information we have for that instance-      -- TODO: is the False here right?-      let newactives = Dep False {- not exe -} qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps)+      let newactives = extractAllDeps pfa psa qdeps       -- We now try to extend the partial assignment with the new active constraints.-      let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives+      let mnppa = extend extSupported langSupported pkgPresent newactives+                   =<< extendWithPackageChoice (PI qpn i) ppa       -- In case we continue, we save the scoped dependencies       let nsvd = M.insert qpn qdeps svd       case mfr of         Just fr -> -- The index marks this as an invalid choice. We can stop.                    return (Fail (varToConflictSet (P qpn)) fr)-        _       -> case mnppa of-                     Left (c, d) -> -- We have an inconsistency. We can stop.-                                    return (Fail c (Conflicting d))-                     Right nppa  -> -- We have an updated partial assignment for the recursive validation.-                                    local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r+        Nothing ->+          let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps)+              newDeps = do+                nppa <- mnppa+                rExes' <- extendRequiredExes aExes rExes newactives+                checkExesInNewPackage rExes qpn exes+                return (nppa, rExes')+          in case newDeps of+               Left (c, fr)         -> -- We have an inconsistency. We can stop.+                                       return (Fail c fr)+               Right (nppa, rExes') -> -- We have an updated partial assignment for the recursive validation.+                                       local (\ s -> s { pa = PA nppa pfa psa+                                                       , saved = nsvd+                                                       , availableExes = M.insert qpn exes aExes+                                                       , requiredExes = rExes'+                                                       }) r      -- What to do for flag nodes ...     goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goF qfn@(FN (PI qpn _i) _f) b r = do+    goF qfn@(FN qpn _f) b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment       extSupported   <- asks supportedExt  -- obtain the supported extensions       langSupported  <- asks supportedLang -- obtain the supported languages       pkgPresent     <- asks presentPkgs   -- obtain the present pkg-config pkgs-      svd <- asks saved         -- obtain saved dependencies+      svd            <- asks saved         -- obtain saved dependencies+      aExes          <- asks availableExes+      rExes          <- asks requiredExes       -- Note that there should be saved dependencies for the package in question,       -- because while building, we do not choose flags before we see the packages       -- that define them.@@ -188,19 +261,24 @@       -- We now try to get the new active dependencies we might learn about because       -- we have chosen a new flag.       let newactives = extractNewDeps (F qfn) b npfa psa qdeps+          mNewRequiredExes = extendRequiredExes aExes rExes newactives       -- As in the package case, we try to extend the partial assignment.-      case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of-        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found-        Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r+      let mnppa = extend extSupported langSupported pkgPresent newactives ppa+      case liftM2 (,) mnppa mNewRequiredExes of+        Left (c, fr)         -> return (Fail c fr) -- inconsistency found+        Right (nppa, rExes') ->+            local (\ s -> s { pa = PA nppa npfa psa, requiredExes = rExes' }) r      -- What to do for stanza nodes (similar to flag nodes) ...     goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goS qsn@(SN (PI qpn _i) _f) b r = do+    goS qsn@(SN qpn _f) b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment       extSupported   <- asks supportedExt  -- obtain the supported extensions       langSupported  <- asks supportedLang -- obtain the supported languages       pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs-      svd <- asks saved         -- obtain saved dependencies+      svd            <- asks saved         -- obtain saved dependencies+      aExes          <- asks availableExes+      rExes          <- asks requiredExes       -- Note that there should be saved dependencies for the package in question,       -- because while building, we do not choose flags before we see the packages       -- that define them.@@ -213,54 +291,197 @@       -- We now try to get the new active dependencies we might learn about because       -- we have chosen a new flag.       let newactives = extractNewDeps (S qsn) b pfa npsa qdeps+          mNewRequiredExes = extendRequiredExes aExes rExes newactives       -- As in the package case, we try to extend the partial assignment.-      case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of-        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found-        Right nppa  -> local (\ s -> s { pa = PA nppa pfa npsa }) r+      let mnppa = extend extSupported langSupported pkgPresent newactives ppa+      case liftM2 (,) mnppa mNewRequiredExes of+        Left (c, fr)         -> return (Fail c fr) -- inconsistency found+        Right (nppa, rExes') ->+            local (\ s -> s { pa = PA nppa pfa npsa, requiredExes = rExes' }) r +-- | Check that a newly chosen package instance contains all executables that+-- are required from that package so far.+checkExesInNewPackage :: Map QPN ExeDeps+                      -> QPN+                      -> [UnqualComponentName]+                      -> Either Conflict ()+checkExesInNewPackage required qpn providedExes =+    case M.toList $ deleteKeys providedExes (M.findWithDefault M.empty qpn required) of+      (missingExe, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr+                              in Left (cs, NewPackageIsMissingRequiredExe missingExe dr)+      []                   -> Right ()+  where+    deleteKeys :: Ord k => [k] -> Map k v -> Map k v+    deleteKeys ks m = L.foldr M.delete m ks+ -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have -- already acquired.-extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]-extractDeps fa sa deps = do+extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]+extractAllDeps fa sa deps = do   d <- deps   case d of     Simple sd _         -> return sd     Flagged qfn _ td fd -> case M.lookup qfn fa of                              Nothing    -> mzero-                             Just True  -> extractDeps fa sa td-                             Just False -> extractDeps fa sa fd+                             Just True  -> extractAllDeps fa sa td+                             Just False -> extractAllDeps fa sa fd     Stanza qsn td       -> case M.lookup qsn sa of                              Nothing    -> mzero-                             Just True  -> extractDeps fa sa td+                             Just True  -> extractAllDeps fa sa td                              Just False -> []  -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call--- 'extractDeps' for everything underneath.-extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]+-- 'extractAllDeps' for everything underneath.+extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] extractNewDeps v b fa sa = go   where-    go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)+    go :: FlaggedDeps QPN -> [LDep QPN]     go deps = do       d <- deps       case d of         Simple _ _           -> mzero         Flagged qfn' _ td fd-          | v == F qfn'      -> L.map (resetVar v) $-                                if b then extractDeps fa sa td else extractDeps fa sa fd+          | v == F qfn'      -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd           | otherwise        -> case M.lookup qfn' fa of                                   Nothing    -> mzero                                   Just True  -> go td                                   Just False -> go fd         Stanza qsn' td-          | v == S qsn'      -> L.map (resetVar v) $-                                if b then extractDeps fa sa td else []+          | v == S qsn'      -> if b then extractAllDeps fa sa td else []           | otherwise        -> case M.lookup qsn' sa of                                   Nothing    -> mzero                                   Just True  -> go td                                   Just False -> [] +-- | Extend a package preassignment.+--+-- Takes the variable that causes the new constraints, a current preassignment+-- and a set of new dependency constraints.+--+-- We're trying to extend the preassignment with each dependency one by one.+-- Each dependency is for a particular variable. We check if we already have+-- constraints for that variable in the current preassignment. If so, we're+-- trying to merge the constraints.+--+-- Either returns a witness of the conflict that would arise during the merge,+-- 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+       -> [LDep QPN]+       -> PPreAssignment+       -> Either Conflict PPreAssignment+extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives+  where++    extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment+    extendSingle a (LDep dr (Ext  ext ))  =+      if extSupported  ext  then Right a+                            else Left (dependencyReasonToCS dr, UnsupportedExtension ext)+    extendSingle a (LDep dr (Lang lang))  =+      if langSupported lang then Right a+                            else Left (dependencyReasonToCS dr, UnsupportedLanguage lang)+    extendSingle a (LDep dr (Pkg pn vr))  =+      if pkgPresent pn vr then Right a+                          else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr)+    extendSingle a (LDep dr (Dep mExe qpn ci)) =+      let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a+      in  case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of+            Left (c, (d, d')) -> Left (c, ConflictingConstraints d d')+            Right x           -> Right x++-- | Extend a package preassignment with a package choice. For example, when+-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0.+extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment+extendWithPackageChoice (PI qpn i) ppa =+  let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa+      newChoice = PkgDep (DependencyReason qpn M.empty S.empty) Nothing qpn (Fixed i)+  in  case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of+        Left (c, (d, _d')) -> -- Don't include the package choice in the+                              -- FailReason, because it is redundant.+                              Left (c, NewPackageDoesNotMatchExistingConstraint d)+        Right x            -> Right x++-- | Merge constrained instances. We currently adopt a lazy strategy for+-- merging, i.e., we only perform actual checking if one of the two choices+-- is fixed. If the merge fails, we return a conflict set indicating the+-- variables responsible for the failure, as well as the two conflicting+-- fragments.+--+-- Note that while there may be more than one conflicting pair of version+-- ranges, we only return the first we find.+--+-- The ConflictingDeps are returned in order, i.e., the first describes the+-- conflicting part of the MergedPkgDep, and the second describes the PkgDep.+--+-- TODO: Different pairs might have different conflict sets. We're+-- obviously interested to return a conflict that has a "better" conflict+-- set in the sense the it contains variables that allow us to backjump+-- further. We might apply some heuristics here, such as to change the+-- order in which we check the constraints.+merge ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep+merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2))+  | i1 == i2  = Right $ MergedDepFixed mExe1 vs1 i1+  | otherwise =+      Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2+           , ( ConflictingDep vs1 mExe1 p (Fixed i1)+             , ConflictingDep vs2 mExe2 p ci ) )++merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr))+  | checkVR vr v = Right $ MergedDepFixed mExe1 vs1 i+  | otherwise    =+      Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2+           , ( ConflictingDep vs1 mExe1 p (Fixed i)+             , ConflictingDep vs2 mExe2 p ci ) )++merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) =+    go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...+  where+    go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep+    go [] = Right (MergedDepFixed mExe2 vs2 i)+    go ((vr, mExe1, vs1) : vros)+       | checkVR vr v = go vros+       | otherwise    =+           Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2+                , ( ConflictingDep vs1 mExe1 p (Constrained vr)+                  , ConflictingDep vs2 mExe2 p ci ) )++merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) =+    Right (MergedDepConstrained $++    -- TODO: This line appends the new version range, to preserve the order used+    -- before a refactoring. Consider prepending the version range, if there is+    -- no negative performance impact.+    vrOrigins ++ [(vr, mExe2, vs2)])++-- | Takes a list of new dependencies and uses it to try to update the map of+-- known executable dependencies. It returns a failure when a new dependency+-- requires an executable that is missing from one of the previously chosen+-- packages.+extendRequiredExes :: Map QPN [UnqualComponentName]+                   -> Map QPN ExeDeps+                   -> [LDep QPN]+                   -> Either Conflict (Map QPN ExeDeps)+extendRequiredExes available = foldM extendSingle+  where+    extendSingle :: Map QPN ExeDeps -> LDep QPN -> Either Conflict (Map QPN ExeDeps)+    extendSingle required (LDep dr (Dep (Just exe) qpn _)) =+      let exeDeps = M.findWithDefault M.empty qpn required+      in -- Only check for the existence of the exe if its package has already+         -- been chosen.+         case M.lookup qpn available of+           Just exes+             | L.notElem exe exes -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr)+                                     in Left (cs, PackageRequiresMissingExe qpn exe)+           _                      -> Right $ M.insertWith M.union qpn (M.insert exe dr exeDeps) required+    extendSingle required _                                = Right required+ -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {@@ -274,5 +495,7 @@   , index          = idx   , saved          = M.empty   , pa             = PA M.empty M.empty M.empty+  , availableExes  = M.empty+  , requiredExes   = M.empty   , qualifyOptions = defaultQualifyOptions idx   }

Distribution/Solver/Modular/Var.hs view

@@ -1,15 +1,13 @@ {-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Modular.Var (     Var(..)-  , simplifyVar   , showVar-  , varPI+  , varPN   ) where  import Prelude hiding (pi)  import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package import Distribution.Solver.Types.PackagePath  {-------------------------------------------------------------------------------@@ -24,23 +22,13 @@ data Var qpn = P qpn | F (FN qpn) | S (SN qpn)   deriving (Eq, Ord, Show, Functor) --- | For computing conflict sets, we map flag choice vars to a--- single flag choice. This means that all flag choices are treated--- as interdependent. So if one flag of a package ends up in a--- conflict set, then all flags are being treated as being part of--- the conflict set.-simplifyVar :: Var qpn -> Var qpn-simplifyVar (P qpn)       = P qpn-simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))-simplifyVar (S qsn)       = S qsn- showVar :: Var QPN -> String showVar (P qpn) = showQPN qpn showVar (F qfn) = showQFN qfn showVar (S qsn) = showQSN qsn --- | Extract the package instance from a Var-varPI :: Var QPN -> (QPN, Maybe I)-varPI (P qpn)               = (qpn, Nothing)-varPI (F (FN (PI qpn i) _)) = (qpn, Just i)-varPI (S (SN (PI qpn i) _)) = (qpn, Just i)+-- | Extract the package name from a Var+varPN :: Var qpn -> qpn+varPN (P qpn)        = qpn+varPN (F (FN qpn _)) = qpn+varPN (S (SN qpn _)) = qpn

Distribution/Solver/Modular/Version.hs view

@@ -38,11 +38,11 @@  -- | Intersect two version ranges. (.&&.) :: VR -> VR -> VR-(.&&.) = CV.intersectVersionRanges+v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2  -- | Union of two version ranges. (.||.) :: VR -> VR -> VR-(.||.) = CV.unionVersionRanges+v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2  -- | Simplify a version range. simplifyVR :: VR -> VR

Distribution/Solver/Modular/WeightedPSQ.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.WeightedPSQ (     WeightedPSQ   , fromList@@ -11,6 +12,7 @@   , mapWithKey   , mapWeightsWithKey   , union+  , takeUntil   ) where  import qualified Data.Foldable as F@@ -75,6 +77,15 @@ -- second when they have the same weight. union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys)++-- | /O(N)/. Return the prefix of values ending with the first element that+-- satisfies p, or all elements if none satisfy p.+takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v+takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs)+  where+    go :: [(w, k, v)] -> [(w, k, v)]+    go []       = []+    go (y : ys) = y : if p (triple_3 y) then [] else go ys  triple_1 :: (x, y, z) -> x triple_1 (x, _, _) = x

Distribution/Solver/Types/ComponentDeps.hs view

@@ -38,7 +38,7 @@  import Prelude () import Distribution.Types.UnqualComponentName-import Distribution.Client.Compat.Prelude hiding (empty,zip)+import Distribution.Solver.Compat.Prelude hiding (empty,zip)  import qualified Data.Map as Map import Data.Foldable (fold)

Distribution/Solver/Types/ConstraintSource.hs view

@@ -49,6 +49,10 @@   -- | An internal constraint due to compatibility issues with the Setup.hs   -- command line interface requires a minimum lower bound on Cabal   | ConstraintSetupCabalMinVersion++  -- | An internal constraint due to compatibility issues with the Setup.hs+  -- command line interface requires a maximum upper bound on Cabal+  | ConstraintSetupCabalMaxVersion   deriving (Eq, Show, Generic)  instance Binary ConstraintSource@@ -74,3 +78,5 @@ showConstraintSource ConstraintSourceUnknown = "unknown source" showConstraintSource ConstraintSetupCabalMinVersion =     "minimum version of Cabal used by Setup.hs"+showConstraintSource ConstraintSetupCabalMaxVersion =+    "maximum version of Cabal used by Setup.hs"

Distribution/Solver/Types/PackageConstraint.hs view

@@ -24,7 +24,7 @@ import Distribution.Types.Dependency   (Dependency(..)) import Distribution.Version            (VersionRange, simplifyVersionRange) -import Distribution.Client.Compat.Prelude ((<<>>))+import Distribution.Solver.Compat.Prelude ((<<>>)) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath @@ -37,8 +37,18 @@ -- | Determines to what packages and in what contexts a -- constraint applies. data ConstraintScope+     -- | A scope that applies when the given package is used as a build target.+     -- In other words, the scope applies iff a goal has a top-level qualifier+     -- and its namespace matches the given package name. A namespace is+     -- considered to match a package name when it is either the default+     -- namespace (for --no-independent-goals) or it is an independent namespace+     -- with the given package name (for --independent-goals).++     -- TODO: Try to generalize the ConstraintScopes once component-based+     -- solving is implemented, and remove this special case for targets.+   = ScopeTarget PackageName      -- | The package with the specified name and qualifier.-   = ScopeQualified Qualifier PackageName+   | ScopeQualified Qualifier PackageName      -- | The package with the specified name when it has a      -- setup qualifier.    | ScopeAnySetupQualifier PackageName@@ -55,11 +65,16 @@  -- | Returns the package name associated with a constraint scope. scopeToPackageName :: ConstraintScope -> PackageName+scopeToPackageName (ScopeTarget pn) = pn scopeToPackageName (ScopeQualified _ pn) = pn scopeToPackageName (ScopeAnySetupQualifier pn) = pn scopeToPackageName (ScopeAnyQualifier pn) = pn  constraintScopeMatches :: ConstraintScope -> QPN -> Bool+constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') =+  let namespaceMatches DefaultNamespace = True+      namespaceMatches (Independent namespacePn) = pn == namespacePn+  in namespaceMatches ns && q == QualToplevel && pn == pn' constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =     q == q' && pn == pn' constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =@@ -70,6 +85,7 @@  -- | Pretty-prints a constraint scope. dispConstraintScope :: ConstraintScope -> Disp.Doc+dispConstraintScope (ScopeTarget pn) = disp pn <<>> Disp.text "." <<>> disp pn dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> disp pn dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> disp pn dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp pn

Distribution/Solver/Types/PackageIndex.hs view

@@ -46,7 +46,7 @@   ) where  import Prelude ()-import Distribution.Client.Compat.Prelude hiding (lookup)+import Distribution.Solver.Compat.Prelude hiding (lookup)  import Control.Exception (assert) import qualified Data.Map as Map

Distribution/Solver/Types/PackagePath.hs view

@@ -12,7 +12,7 @@ import Distribution.Package import Distribution.Text import qualified Text.PrettyPrint as Disp-import Distribution.Client.Compat.Prelude ((<<>>))+import Distribution.Solver.Compat.Prelude ((<<>>))  -- | A package path consists of a namespace and a package path inside that -- namespace.@@ -27,17 +27,15 @@     -- | The default namespace     DefaultNamespace -    -- | Independent namespace-    ---    -- For now we just number these (rather than giving them more structure).-  | Independent Int+    -- | A namespace for a specific build target+  | Independent PackageName   deriving (Eq, Ord, Show)  -- | Pretty-prints a namespace. The result is either empty or -- ends in a period, so it can be prepended onto a qualifier. dispNamespace :: Namespace -> Disp.Doc dispNamespace DefaultNamespace = Disp.empty-dispNamespace (Independent i) = Disp.int i <<>> Disp.text "."+dispNamespace (Independent i) = disp i <<>> Disp.text "."  -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier =

Distribution/Solver/Types/PkgConfigDb.hs view

@@ -21,7 +21,7 @@     ) where  import Prelude ()-import Distribution.Client.Compat.Prelude+import Distribution.Solver.Compat.Prelude  import Control.Exception (IOException, handle) import qualified Data.Map as M

Distribution/Solver/Types/Progress.hs view

@@ -4,7 +4,7 @@     ) where  import Prelude ()-import Distribution.Client.Compat.Prelude hiding (fail)+import Distribution.Solver.Compat.Prelude hiding (fail)  -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final

Distribution/Solver/Types/SolverPackage.hs view

@@ -20,8 +20,8 @@ -- but for symmetry we have the parameter.  (Maybe it can be removed.) -- data SolverPackage loc = SolverPackage {-        solverPkgSource :: SourcePackage loc,-        solverPkgFlags :: FlagAssignment,+        solverPkgSource  :: SourcePackage loc,+        solverPkgFlags   :: FlagAssignment,         solverPkgStanzas :: [OptionalStanza],         solverPkgLibDeps :: ComponentDeps [SolverId],         solverPkgExeDeps :: ComponentDeps [SolverId]

Distribution/Solver/Types/Variable.hs view

@@ -5,10 +5,9 @@ import Distribution.PackageDescription (FlagName)  -- | Variables used by the dependency solver. This type is similar to the--- internal 'Var' type, except that flags and stanzas are associated with--- package names instead of package instances.+-- internal 'Var' type. data Variable qpn =     PackageVar qpn   | FlagVar qpn FlagName   | StanzaVar qpn OptionalStanza-  deriving Eq+  deriving (Eq, Show)

− Main.hs

@@ -1,1226 +0,0 @@-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  Main--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ Entry point to the default cabal-install front-end.--------------------------------------------------------------------------------module Main (main) where--import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand, withRepoContext-         , ConfigFlags(..)-         , ConfigExFlags(..), defaultConfigExFlags, configureExCommand-         , reconfigureCommand-         , configCompilerAux', configPackageDB'-         , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)-         , buildCommand, replCommand, testCommand, benchmarkCommand-         , InstallFlags(..), defaultInstallFlags-         , installCommand, upgradeCommand, uninstallCommand-         , FetchFlags(..), fetchCommand-         , FreezeFlags(..), freezeCommand-         , genBoundsCommand-         , OutdatedFlags(..), outdatedCommand-         , GetFlags(..), getCommand, unpackCommand-         , checkCommand-         , formatCommand-         , updateCommand-         , ListFlags(..), listCommand-         , InfoFlags(..), infoCommand-         , UploadFlags(..), uploadCommand-         , ReportFlags(..), reportCommand-         , runCommand-         , InitFlags(initVerbosity), initCommand-         , SDistFlags(..), SDistExFlags(..), sdistCommand-         , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand-         , ActAsSetupFlags(..), actAsSetupCommand-         , SandboxFlags(..), sandboxCommand-         , ExecFlags(..), execCommand-         , UserConfigFlags(..), userConfigCommand-         , reportCommand-         , manpageCommand-         )-import Distribution.Simple.Setup-         ( HaddockTarget(..)-         , DoctestFlags(..), doctestCommand-         , HaddockFlags(..), haddockCommand, defaultHaddockFlags-         , HscolourFlags(..), hscolourCommand-         , ReplFlags(..)-         , CopyFlags(..), copyCommand-         , RegisterFlags(..), registerCommand-         , CleanFlags(..), cleanCommand-         , TestFlags(..), BenchmarkFlags(..)-         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag-         , configAbsolutePaths-         )--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (get)--import Distribution.Client.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Config-         ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff-         , userConfigUpdate, createDefaultConfigFile, getConfigFilePath )-import Distribution.Client.Targets-         ( readUserTargets )-import qualified Distribution.Client.List as List-         ( list, info )--import qualified Distribution.Client.CmdConfigure as CmdConfigure-import qualified Distribution.Client.CmdBuild     as CmdBuild-import qualified Distribution.Client.CmdRepl      as CmdRepl-import qualified Distribution.Client.CmdFreeze    as CmdFreeze-import qualified Distribution.Client.CmdHaddock   as CmdHaddock-import qualified Distribution.Client.CmdRun       as CmdRun-import qualified Distribution.Client.CmdTest      as CmdTest-import qualified Distribution.Client.CmdBench     as CmdBench--import Distribution.Client.Install            (install)-import Distribution.Client.Configure          (configure, writeConfigFlags)-import Distribution.Client.Update             (update)-import Distribution.Client.Exec               (exec)-import Distribution.Client.Fetch              (fetch)-import Distribution.Client.Freeze             (freeze)-import Distribution.Client.GenBounds          (genBounds)-import Distribution.Client.Outdated           (outdated)-import Distribution.Client.Check as Check     (check)---import Distribution.Client.Clean            (clean)-import qualified Distribution.Client.Upload as Upload-import Distribution.Client.Run                (run, splitRunArgs)-import Distribution.Client.SrcDist            (sdist)-import Distribution.Client.Get                (get)-import Distribution.Client.Reconfigure        (Check(..), reconfigure)-import Distribution.Client.Nix                (nixInstantiate-                                              ,nixShell-                                              ,nixShellIfSandboxed)-import Distribution.Client.Sandbox            (sandboxInit-                                              ,sandboxAddSource-                                              ,sandboxDelete-                                              ,sandboxDeleteSource-                                              ,sandboxListSources-                                              ,sandboxHcPkg-                                              ,dumpPackageEnvironment--                                              ,loadConfigOrSandboxConfig-                                              ,findSavedDistPref-                                              ,initPackageDBIfNeeded-                                              ,maybeWithSandboxDirOnSearchPath-                                              ,maybeWithSandboxPackageInfo-                                              ,tryGetIndexFilePath-                                              ,sandboxBuildDir-                                              ,updateSandboxConfigFileFlag-                                              ,updateInstallDirs--                                              ,getPersistOrConfigCompiler)-import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB)-import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord)-import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox)-import Distribution.Client.Tar                (createTarGzFile)-import Distribution.Client.Types              (Password (..))-import Distribution.Client.Init               (initCabal)-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)-import Distribution.PackageDescription-         ( BuildType(..), Executable(..), buildable )-#ifdef CABAL_PARSEC-import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )-#else-import Distribution.PackageDescription.Parse ( readGenericPackageDescription )-#endif--import Distribution.PackageDescription.PrettyPrint-         ( writeGenericPackageDescription )-import qualified Distribution.Simple as Simple-import qualified Distribution.Make as Make-import qualified Distribution.Types.UnqualComponentName as Make-import Distribution.Simple.Build-         ( startInterpreter )-import Distribution.Simple.Command-         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)-         , CommandType(..), commandsRun, commandAddAction, hiddenCommand-         , commandFromSpec, commandShowOptions )-import Distribution.Simple.Compiler (Compiler(..), PackageDBStack)-import Distribution.Simple.Configure-         ( configCompilerAuxEx, ConfigStateFileError(..)-         , getPersistBuildConfig, interpretPackageDbFlags-         , tryGetPersistBuildConfig )-import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Program (defaultProgramDb-                                   ,configureAllKnownPrograms-                                   ,simpleProgramInvocation-                                   ,getProgramInvocationOutput)-import Distribution.Simple.Program.Db (reconfigurePrograms)-import qualified Distribution.Simple.Setup as Cabal-import Distribution.Simple.Utils-         ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler-         , findPackageDesc, tryFindPackageDesc )-import Distribution.Text-         ( display )-import Distribution.Verbosity as Verbosity-         ( Verbosity, normal )-import Distribution.Version-         ( Version, mkVersion, orLaterVersion )-import qualified Paths_cabal_install (version)--import System.Environment       (getArgs, getProgName)-import System.Exit              (exitFailure, exitSuccess)-import System.FilePath          ( dropExtension, splitExtension-                                , takeExtension, (</>), (<.>))-import System.IO                ( BufferMode(LineBuffering), hSetBuffering-#ifdef mingw32_HOST_OS-                                , stderr-#endif-                                , stdout )-import System.Directory         (doesFileExist, getCurrentDirectory)-import Data.Monoid              (Any(..))-import Control.Exception        (SomeException(..), try)-import Control.Monad            (mapM_)--#ifdef MONOLITHIC-import qualified UnitTests-import qualified MemoryUsageTests-import qualified SolverQuickCheck-import qualified IntegrationTests2-import qualified System.Environment as Monolithic-#endif---- | Entry point----main :: IO ()-#ifdef MONOLITHIC-main = do-    mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE"-    case mb_exec of-        Just "UnitTests"         -> UnitTests.main-        Just "MemoryUsageTests"  -> MemoryUsageTests.main-        Just "SolverQuickCheck"  -> SolverQuickCheck.main-        Just "IntegrationTests2" -> IntegrationTests2.main-        Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE"-        Nothing -> main'-#else-main = main'-#endif--main' :: IO ()-main' = do-  -- 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-  relaxEncodingErrors stdout-  relaxEncodingErrors stderr-#endif-  getArgs >>= mainWorker--mainWorker :: [String] -> IO ()-mainWorker args = topHandler $-  case commandsRun (globalCommand commands) commands args of-    CommandHelp   help                 -> printGlobalHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (globalFlags, commandParse)  ->-      case commandParse of-        _ | fromFlagOrDefault False (globalVersion globalFlags)-            -> printVersion-          | fromFlagOrDefault False (globalNumericVersion globalFlags)-            -> printNumericVersion-        CommandHelp     help           -> printCommandHelp help-        CommandList     opts           -> printOptionsList opts-        CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> do-          globalFlags' <- updateSandboxConfigFileFlag globalFlags-          action globalFlags'--  where-    printCommandHelp help = do-      pname <- getProgName-      putStr (help pname)-    printGlobalHelp help = do-      pname <- getProgName-      configFile <- defaultConfigFile-      putStr (help pname)-      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"-            ++ "  " ++ configFile ++ "\n"-      exists <- doesFileExist configFile-      when (not exists) $-          putStrLn $ "This file will be generated with sensible "-                  ++ "defaults if you run 'cabal update'."-    printOptionsList = putStr . unlines-    printErrors errs = dieNoVerbosity $ intercalate "\n" errs-    printNumericVersion = putStrLn $ display Paths_cabal_install.version-    printVersion        = putStrLn $ "cabal-install version "-                                  ++ display Paths_cabal_install.version-                                  ++ "\ncompiled using version "-                                  ++ display cabalVersion-                                  ++ " of the Cabal library "--    commands = map commandFromSpec commandSpecs-    commandSpecs =-      [ regularCmd installCommand installAction-      , regularCmd updateCommand updateAction-      , regularCmd listCommand listAction-      , regularCmd infoCommand infoAction-      , regularCmd fetchCommand fetchAction-      , regularCmd freezeCommand freezeAction-      , regularCmd getCommand getAction-      , hiddenCmd  unpackCommand unpackAction-      , regularCmd checkCommand checkAction-      , regularCmd sdistCommand sdistAction-      , regularCmd uploadCommand uploadAction-      , regularCmd reportCommand reportAction-      , regularCmd runCommand runAction-      , regularCmd initCommand initAction-      , regularCmd configureExCommand configureAction-      , regularCmd reconfigureCommand reconfigureAction-      , regularCmd buildCommand buildAction-      , regularCmd replCommand replAction-      , regularCmd sandboxCommand sandboxAction-      , regularCmd doctestCommand doctestAction-      , regularCmd haddockCommand haddockAction-      , regularCmd execCommand execAction-      , regularCmd userConfigCommand userConfigAction-      , regularCmd cleanCommand cleanAction-      , regularCmd genBoundsCommand genBoundsAction-      , regularCmd outdatedCommand outdatedAction-      , wrapperCmd copyCommand copyVerbosity copyDistPref-      , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref-      , wrapperCmd registerCommand regVerbosity regDistPref-      , regularCmd testCommand testAction-      , regularCmd benchmarkCommand benchmarkAction-      , hiddenCmd  uninstallCommand uninstallAction-      , hiddenCmd  formatCommand formatAction-      , hiddenCmd  upgradeCommand upgradeAction-      , hiddenCmd  win32SelfUpgradeCommand win32SelfUpgradeAction-      , hiddenCmd  actAsSetupCommand actAsSetupAction-      , hiddenCmd  manpageCommand (manpageAction commandSpecs)--      , regularCmd  CmdConfigure.configureCommand CmdConfigure.configureAction-      , regularCmd  CmdBuild.buildCommand         CmdBuild.buildAction-      , regularCmd  CmdRepl.replCommand           CmdRepl.replAction-      , regularCmd  CmdFreeze.freezeCommand       CmdFreeze.freezeAction-      , regularCmd  CmdHaddock.haddockCommand     CmdHaddock.haddockAction-      , regularCmd  CmdRun.runCommand             CmdRun.runAction-      , regularCmd  CmdTest.testCommand           CmdTest.testAction-      , regularCmd  CmdBench.benchCommand         CmdBench.benchAction-      ]--type Action = GlobalFlags -> IO ()--regularCmd :: CommandUI flags -> (flags -> [String] -> action)-           -> CommandSpec action-regularCmd ui action =-  CommandSpec ui ((flip commandAddAction) action) NormalCommand--hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)-          -> CommandSpec action-hiddenCmd ui action =-  CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))-  HiddenCommand--wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)-           -> (flags -> Flag String) -> CommandSpec Action-wrapperCmd ui verbosity distPref =-  CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand--wrapperAction :: Monoid flags-              => CommandUI flags-              -> (flags -> Flag Verbosity)-              -> (flags -> Flag String)-              -> Command Action-wrapperAction command verbosityFlag distPrefFlag =-  commandAddAction command-    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do-    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)-    load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-    let config = either (\(SomeException _) -> mempty) snd load-    distPref <- findSavedDistPref config (distPrefFlag flags)-    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }-    setupWrapper verbosity setupScriptOptions Nothing-                 command (const flags) extraArgs--configureAction :: (ConfigFlags, ConfigExFlags)-                -> [String] -> Action-configureAction (configFlags, configExFlags) extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)-                          <$> loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (configDistPref configFlags)-  nixInstantiate verbosity distPref True globalFlags config-  nixShell verbosity distPref globalFlags config $ do-    let configFlags'   = savedConfigureFlags   config `mappend` configFlags-        configExFlags' = savedConfigureExFlags config `mappend` configExFlags-        globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-    (comp, platform, progdb) <- configCompilerAuxEx configFlags'--    -- If we're working inside a sandbox and the user has set the -w option, we-    -- may need to create a sandbox-local package DB for this compiler and add a-    -- timestamp record for this compiler to the timestamp file.-    let configFlags''  = case useSandbox of-          NoSandbox               -> configFlags'-          (UseSandbox sandboxDir) -> setPackageDB sandboxDir-                                    comp platform configFlags'--    writeConfigFlags verbosity distPref (configFlags'', configExFlags')--    -- What package database(s) to use-    let packageDBs :: PackageDBStack-        packageDBs-          = interpretPackageDbFlags-            (fromFlag (configUserInstall configFlags''))-            (configPackageDBs configFlags'')--    whenUsingSandbox useSandbox $ \sandboxDir -> do-      initPackageDBIfNeeded verbosity configFlags'' comp progdb-      -- NOTE: We do not write the new sandbox package DB location to-      -- 'cabal.sandbox.config' here because 'configure -w' must not affect-      -- subsequent 'install' (for UI compatibility with non-sandboxed mode).--      indexFile     <- tryGetIndexFilePath verbosity config-      maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile-        (compilerId comp) platform--    maybeWithSandboxDirOnSearchPath useSandbox $-      withRepoContext verbosity globalFlags' $ \repoContext ->-        configure verbosity packageDBs repoContext-                  comp platform progdb configFlags'' configExFlags' extraArgs--reconfigureAction :: (ConfigFlags, ConfigExFlags)-                  -> [String] -> Action-reconfigureAction flags@(configFlags, _) _ globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)-                          <$> loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (configDistPref configFlags)-  let checkFlags = Check $ \_ saved -> do-        let flags' = saved <> flags-        unless (saved == flags') $ info verbosity message-        pure (Any True, flags')-        where-          -- This message is correct, but not very specific: it will list all-          -- of the new flags, even if some have not actually changed. The-          -- *minimal* set of changes is more difficult to determine.-          message =-            "flags changed: "-            ++ unwords (commandShowOptions configureExCommand flags)-  nixInstantiate verbosity distPref True globalFlags config-  _ <--    reconfigure configureAction-    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag-    checkFlags [] globalFlags config-  pure ()--buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action-buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)-      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck-                    (buildOnly buildExFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (buildDistPref buildFlags)-  -- Calls 'configureAction' to do the real work, so nothing special has to be-  -- done to support sandboxes.-  config' <--    reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)-    mempty [] globalFlags config-  nixShell verbosity distPref globalFlags config $ do-    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config' distPref buildFlags extraArgs----- | Actually do the work of building the package. This is separate from--- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke--- 'reconfigure' twice.-build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()-build verbosity config distPref buildFlags extraArgs =-  setupWrapper verbosity setupOptions Nothing-               (Cabal.buildCommand progDb) mkBuildFlags extraArgs-  where-    progDb       = defaultProgramDb-    setupOptions = defaultSetupScriptOptions { useDistPref = distPref }--    mkBuildFlags version = filterBuildFlags version config buildFlags'-    buildFlags' = buildFlags-      { buildVerbosity = toFlag verbosity-      , buildDistPref  = toFlag distPref-      }---- | Make sure that we don't pass new flags to setup scripts compiled against--- old versions of Cabal.-filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags-filterBuildFlags version config buildFlags-  | version >= mkVersion [1,19,1] = buildFlags_latest-  -- Cabal < 1.19.1 doesn't support 'build -j'.-  | otherwise                      = buildFlags_pre_1_19_1-  where-    buildFlags_pre_1_19_1 = buildFlags {-      buildNumJobs = NoFlag-      }-    buildFlags_latest     = buildFlags {-      -- Take the 'jobs' setting '~/.cabal/config' into account.-      buildNumJobs = Flag . Just . determineNumJobs $-                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)-      }-    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config-    numJobsCmdLineFlag = buildNumJobs buildFlags---replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action-replAction (replFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (replVerbosity replFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (replDistPref replFlags)-  cwd     <- getCurrentDirectory-  pkgDesc <- findPackageDesc cwd-  let-    -- There is a .cabal file in the current directory: start a REPL and load-    -- the project's modules.-    onPkgDesc = do-      let noAddSource = case replReload replFlags of-            Flag True -> SkipAddSourceDepsCheck-            _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck-                        (buildOnly buildExFlags)--      -- Calls 'configureAction' to do the real work, so nothing special has to-      -- be done to support sandboxes.-      _ <--        reconfigure configureAction-        verbosity distPref useSandbox noAddSource NoFlag-        mempty [] globalFlags config-      let progDb = defaultProgramDb-          setupOptions = defaultSetupScriptOptions-            { useCabalVersion = orLaterVersion $ mkVersion [1,18,0]-            , useDistPref     = distPref-            }-          replFlags'   = replFlags-            { replVerbosity = toFlag verbosity-            , replDistPref  = toFlag distPref-            }--      nixShell verbosity distPref globalFlags config $ do-        maybeWithSandboxDirOnSearchPath useSandbox $-          setupWrapper verbosity setupOptions Nothing-          (Cabal.replCommand progDb) (const replFlags') extraArgs--    -- No .cabal file in the current directory: just start the REPL (possibly-    -- using the sandbox package DB).-    onNoPkgDesc = do-      let configFlags = savedConfigureFlags config-      (comp, platform, programDb) <- configCompilerAux' configFlags-      programDb' <- reconfigurePrograms verbosity-                                        (replProgramPaths replFlags)-                                        (replProgramArgs replFlags)-                                        programDb-      nixShell verbosity distPref globalFlags config $ do-        startInterpreter verbosity programDb' comp platform-                        (configPackageDB' configFlags)--  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc--installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> Action-installAction (configFlags, _, installFlags, _) _ globalFlags-  | fromFlagOrDefault False (installOnly installFlags) = do-      let verb = fromFlagOrDefault normal (configVerbosity configFlags)-      (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags-      dist <- findSavedDistPref config (configDistPref configFlags)-      let setupOpts = defaultSetupScriptOptions { useDistPref = dist }-      nixShellIfSandboxed verb dist globalFlags config useSandbox $-        setupWrapper-        verb setupOpts Nothing-        installCommand (const mempty) []--installAction-  (configFlags, configExFlags, installFlags, haddockFlags)-  extraArgs globalFlags = do-  let verb = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)-                          <$> loadConfigOrSandboxConfig verb globalFlags--  let sandboxDist =-        case useSandbox of-          NoSandbox             -> NoFlag-          UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir-  dist <- findSavedDistPref config-          (configDistPref configFlags `mappend` sandboxDist)--  nixShellIfSandboxed verb dist globalFlags config useSandbox $ do-    targets <- readUserTargets verb extraArgs--    -- 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 build && cabal install-    ---    -- performs the compilation twice unless you also pass -w to 'install'.-    -- However, this is the same behaviour that 'cabal install' has in the normal-    -- mode of operation, so we stick to it for consistency.--    let configFlags'    = maybeForceTests installFlags' $-                          savedConfigureFlags   config `mappend`-                          configFlags { configDistPref = toFlag dist }-        configExFlags'  = defaultConfigExFlags         `mappend`-                          savedConfigureExFlags config `mappend` configExFlags-        installFlags'   = defaultInstallFlags          `mappend`-                          savedInstallFlags     config `mappend` installFlags-        haddockFlags'   = defaultHaddockFlags          `mappend`-                          savedHaddockFlags     config `mappend`-                          haddockFlags { haddockDistPref = toFlag dist }-        globalFlags'    = savedGlobalFlags      config `mappend` globalFlags-    (comp, platform, progdb) <- configCompilerAux' configFlags'-    -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the-    -- future.-    progdb' <- configureAllKnownPrograms verb progdb--    -- If we're working inside a sandbox and the user has set the -w option, we-    -- may need to create a sandbox-local package DB for this compiler and add a-    -- timestamp record for this compiler to the timestamp file.-    configFlags'' <- case useSandbox of-      NoSandbox               -> configAbsolutePaths $ configFlags'-      (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform-                                                      configFlags'--    whenUsingSandbox useSandbox $ \sandboxDir -> do-      initPackageDBIfNeeded verb configFlags'' comp progdb'--      indexFile     <- tryGetIndexFilePath verb config-      maybeAddCompilerTimestampRecord verb sandboxDir indexFile-        (compilerId comp) platform--    -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means-    -- that 'cabal install some-package' inside a sandbox will sometimes reinstall-    -- modified add-source deps, even if they are not among the dependencies of-    -- 'some-package'. This can also prevent packages that depend on older-    -- versions of add-source'd packages from building (see #1362).-    maybeWithSandboxPackageInfo verb configFlags'' globalFlags'-                                comp platform progdb useSandbox $ \mSandboxPkgInfo ->-                                maybeWithSandboxDirOnSearchPath useSandbox $-      withRepoContext verb globalFlags' $ \repoContext ->-        install verb-                (configPackageDB' configFlags'')-                repoContext-                comp platform progdb'-                useSandbox mSandboxPkgInfo-                globalFlags' configFlags'' configExFlags'-                installFlags' haddockFlags'-                targets--      where-        -- '--run-tests' implies '--enable-tests'.-        maybeForceTests installFlags' configFlags' =-          if fromFlagOrDefault False (installRunTests installFlags')-          then configFlags' { configTests = toFlag True }-          else configFlags'--testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags-           -> IO ()-testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (testDistPref testFlags)-  let noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck-                      (buildOnly buildExFlags)-      buildFlags'    = buildFlags-                      { buildVerbosity = testVerbosity testFlags }-      checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->-        if fromFlagOrDefault False (configTests configFlags)-          then pure (mempty, flags)-          else do-            info verbosity "reconfiguring to enable tests"-            let flags' = ( configFlags { configTests = toFlag True }-                        , configExFlags-                        )-            pure (Any True, flags')--  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.-  _ <--    reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')-    checkFlags [] globalFlags config-  nixShell verbosity distPref globalFlags config $ do-    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }-        testFlags'     = testFlags { testDistPref = toFlag distPref }--    -- The package was just configured, so the LBI must be available.-    names <- componentNamesFromLBI verbosity distPref "test suites"-              (\c -> case c of { LBI.CTest{} -> True; _ -> False })-    let extraArgs'-          | null extraArgs = case names of-            ComponentNamesUnknown -> []-            ComponentNames names' -> [ Make.unUnqualComponentName name-                                    | LBI.CTestName name <- names' ]-          | otherwise      = extraArgs--    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config distPref buildFlags' extraArgs'--    maybeWithSandboxDirOnSearchPath useSandbox $-      setupWrapper verbosity setupOptions Nothing-      Cabal.testCommand (const testFlags') extraArgs'--data ComponentNames = ComponentNamesUnknown-                    | ComponentNames [LBI.ComponentName]---- | Return the names of all buildable components matching a given predicate.-componentNamesFromLBI :: Verbosity -> FilePath -> String-                         -> (LBI.Component -> Bool)-                         -> IO ComponentNames-componentNamesFromLBI verbosity distPref targetsDescr compPred = do-  eLBI <- tryGetPersistBuildConfig distPref-  case eLBI of-    Left err -> case err of-      -- Note: the build config could have been generated by a custom setup-      -- script built against a different Cabal version, so it's crucial that-      -- we ignore the bad version error here.-      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown-      _                               -> die' verbosity (show err)-    Right lbi -> do-      let pkgDescr = LBI.localPkgDescr lbi-          names    = map LBI.componentName-                     . filter (buildable . LBI.componentBuildInfo)-                     . filter compPred $-                     LBI.pkgComponents pkgDescr-      if null names-        then do notice verbosity $ "Package has no buildable "-                  ++ targetsDescr ++ "."-                exitSuccess -- See #3215.--        else return $! (ComponentNames names)--benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)-                   -> [String] -> GlobalFlags-                   -> IO ()-benchmarkAction-  (benchmarkFlags, buildFlags, buildExFlags)-  extraArgs globalFlags = do-  let verbosity      = fromFlagOrDefault normal-                       (benchmarkVerbosity benchmarkFlags)--  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)-  let buildFlags'    = buildFlags-                      { buildVerbosity = benchmarkVerbosity benchmarkFlags }-      noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck-                      (buildOnly buildExFlags)--  let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->-        if fromFlagOrDefault False (configBenchmarks configFlags)-          then pure (mempty, flags)-          else do-            info verbosity "reconfiguring to enable benchmarks"-            let flags' = ( configFlags { configBenchmarks = toFlag True }-                        , configExFlags-                        )-            pure (Any True, flags')---  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.-  config' <--    reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')-    checkFlags [] globalFlags config-  nixShell verbosity distPref globalFlags config $ do-    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }-        benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }--    -- The package was just configured, so the LBI must be available.-    names <- componentNamesFromLBI verbosity distPref "benchmarks"-            (\c -> case c of { LBI.CBench{} -> True; _ -> False; })-    let extraArgs'-          | null extraArgs = case names of-            ComponentNamesUnknown -> []-            ComponentNames names' -> [ Make.unUnqualComponentName name-                                    | LBI.CBenchName name <- names']-          | otherwise      = extraArgs--    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config' distPref buildFlags' extraArgs'--    maybeWithSandboxDirOnSearchPath useSandbox $-      setupWrapper verbosity setupOptions Nothing-      Cabal.benchmarkCommand (const benchmarkFlags') extraArgs'--haddockAction :: HaddockFlags -> [String] -> Action-haddockAction haddockFlags extraArgs globalFlags = do-  let verbosity = fromFlag (haddockVerbosity haddockFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (haddockDistPref haddockFlags)-  config' <--    reconfigure configureAction-    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag-    mempty [] globalFlags config-  nixShell verbosity distPref globalFlags config $ do-    let haddockFlags' = defaultHaddockFlags      `mappend`-                        savedHaddockFlags config' `mappend`-                        haddockFlags { haddockDistPref = toFlag distPref }-        setupScriptOptions = defaultSetupScriptOptions-                             { useDistPref = distPref }-    setupWrapper verbosity setupScriptOptions Nothing-      haddockCommand (const haddockFlags') extraArgs-    when (haddockForHackage haddockFlags == Flag ForHackage) $ do-      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)-      let dest = distPref </> name <.> "tar.gz"-          name = display (packageId pkg) ++ "-docs"-          docDir = distPref </> "doc" </> "html"-      createTarGzFile dest docDir name-      notice verbosity $ "Documentation tarball created: " ++ dest--doctestAction :: DoctestFlags -> [String] -> Action-doctestAction doctestFlags extraArgs _globalFlags = do-  let verbosity = fromFlag (doctestVerbosity doctestFlags)--  setupWrapper verbosity defaultSetupScriptOptions Nothing-    doctestCommand (const doctestFlags) extraArgs--cleanAction :: CleanFlags -> [String] -> Action-cleanAction cleanFlags extraArgs globalFlags = do-  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-  let config = either (\(SomeException _) -> mempty) snd load-  distPref <- findSavedDistPref config (cleanDistPref cleanFlags)-  let setupScriptOptions = defaultSetupScriptOptions-                           { useDistPref = distPref-                           , useWin32CleanHack = True-                           }-      cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }-  setupWrapper verbosity setupScriptOptions Nothing-               cleanCommand (const cleanFlags') extraArgs-  where-    verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)--listAction :: ListFlags -> [String] -> Action-listAction listFlags extraArgs globalFlags = do-  let verbosity = fromFlag (listVerbosity listFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let configFlags' = savedConfigureFlags config-      configFlags  = configFlags' {-        configPackageDBs = configPackageDBs configFlags'-                           `mappend` listPackageDBs listFlags-        }-      globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, progdb) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    List.list verbosity-       (configPackageDB' configFlags)-       repoContext-       comp-       progdb-       listFlags-       extraArgs--infoAction :: InfoFlags -> [String] -> Action-infoAction infoFlags extraArgs globalFlags = do-  let verbosity = fromFlag (infoVerbosity infoFlags)-  targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let configFlags' = savedConfigureFlags config-      configFlags  = configFlags' {-        configPackageDBs = configPackageDBs configFlags'-                           `mappend` infoPackageDBs infoFlags-        }-      globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, progdb) <- configCompilerAuxEx configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    List.info verbosity-       (configPackageDB' configFlags)-       repoContext-       comp-       progdb-       globalFlags'-       infoFlags-       targets--updateAction :: Flag Verbosity -> [String] -> Action-updateAction verbosityFlag extraArgs globalFlags = do-  let verbosity = fromFlag verbosityFlag-  unless (null extraArgs) $-    die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    update verbosity repoContext--upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> Action-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 "- ++ "confusing and it often led to broken packages.\n"- ++ "If you want the old upgrade behaviour then use the install command "- ++ "with the --upgrade-dependencies flag (but check first with --dry-run "- ++ "to see what would happen). This will try to pick the latest versions "- ++ "of all dependencies, rather than the usual behaviour of trying to pick "- ++ "installed versions of all dependencies. If you do use "- ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "- ++ "packages (e.g. by using appropriate --constraint= flags)."- where-  verbosity = fromFlag (configVerbosity configFlags)--fetchAction :: FetchFlags -> [String] -> Action-fetchAction fetchFlags extraArgs globalFlags = do-  let verbosity = fromFlag (fetchVerbosity fetchFlags)-  targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags)-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, progdb) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    fetch verbosity-        (configPackageDB' configFlags)-        repoContext-        comp platform progdb globalFlags' fetchFlags-        targets--freezeAction :: FreezeFlags -> [String] -> Action-freezeAction freezeFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config NoFlag-  nixShell verbosity distPref globalFlags config $ do-    let configFlags  = savedConfigureFlags config-        globalFlags' = savedGlobalFlags config `mappend` globalFlags-    (comp, platform, progdb) <- configCompilerAux' configFlags--    maybeWithSandboxPackageInfo-      verbosity configFlags globalFlags'-      comp platform progdb useSandbox $ \mSandboxPkgInfo ->-        maybeWithSandboxDirOnSearchPath useSandbox $-        withRepoContext verbosity globalFlags' $ \repoContext ->-          freeze verbosity-            (configPackageDB' configFlags)-            repoContext-            comp platform progdb-            mSandboxPkgInfo-            globalFlags' freezeFlags--genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()-genBoundsAction freezeFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config NoFlag-  nixShell verbosity distPref globalFlags config $ do-    let configFlags  = savedConfigureFlags config-        globalFlags' = savedGlobalFlags config `mappend` globalFlags-    (comp, platform, progdb) <- configCompilerAux' configFlags--    maybeWithSandboxPackageInfo-      verbosity configFlags globalFlags'-      comp platform progdb useSandbox $ \mSandboxPkgInfo ->-        maybeWithSandboxDirOnSearchPath useSandbox $-        withRepoContext verbosity globalFlags' $ \repoContext ->-          genBounds verbosity-                (configPackageDB' configFlags)-                repoContext-                comp platform progdb-                mSandboxPkgInfo-                globalFlags' freezeFlags--outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO ()-outdatedAction outdatedFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (outdatedVerbosity outdatedFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, _progdb) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    outdated verbosity outdatedFlags repoContext-             comp platform--uploadAction :: UploadFlags -> [String] -> Action-uploadAction uploadFlags extraArgs globalFlags = do-  config <- loadConfig verbosity (globalConfigFile globalFlags)-  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-      tarfiles     = extraArgs-  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $-    die' verbosity "the 'upload' command expects at least one .tar.gz archive."-  checkTarFiles extraArgs-  maybe_password <--    case uploadPasswordCmd uploadFlags'-    of Flag (xs:xss) -> Just . Password <$>-                        getProgramInvocationOutput verbosity-                        (simpleProgramInvocation xs xss)-       _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'-  withRepoContext verbosity globalFlags' $ \repoContext -> do-    if fromFlag (uploadDoc uploadFlags')-    then do-      when (length tarfiles > 1) $-       die' verbosity $ "the 'upload' command can only upload documentation "-             ++ "for one package at a time."-      tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles-      Upload.uploadDoc verbosity-                       repoContext-                       (flagToMaybe $ uploadUsername uploadFlags')-                       maybe_password-                       (fromFlag (uploadCandidate uploadFlags'))-                       tarfile-    else do-      Upload.upload verbosity-                    repoContext-                    (flagToMaybe $ uploadUsername uploadFlags')-                    maybe_password-                    (fromFlag (uploadCandidate uploadFlags'))-                    tarfiles-    where-    verbosity = fromFlag (uploadVerbosity uploadFlags)-    checkTarFiles tarfiles-      | not (null otherFiles)-      = die' verbosity $ "the 'upload' command expects only .tar.gz archives: "-           ++ intercalate ", " otherFiles-      | otherwise = sequence_-                      [ do exists <- doesFileExist tarfile-                           unless exists $ die' verbosity $ "file not found: " ++ tarfile-                      | tarfile <- tarfiles ]--      where otherFiles = filter (not . isTarGzFile) tarfiles-            isTarGzFile file = case splitExtension file of-              (file', ".gz") -> takeExtension file' == ".tar"-              _              -> False-    generateDocTarball config = do-      notice verbosity $-        "No documentation tarball specified. "-        ++ "Building a documentation tarball with default settings...\n"-        ++ "If you need to customise Haddock options, "-        ++ "run 'haddock --for-hackage' first "-        ++ "to generate a documentation tarball."-      haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage })-                    [] globalFlags-      distPref <- findSavedDistPref config NoFlag-      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)-      return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"--checkAction :: Flag Verbosity -> [String] -> Action-checkAction verbosityFlag extraArgs _globalFlags = do-  let verbosity = fromFlag verbosityFlag-  unless (null extraArgs) $-    die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs-  allOk <- Check.check (fromFlag verbosityFlag)-  unless allOk exitFailure--formatAction :: Flag Verbosity -> [String] -> Action-formatAction verbosityFlag extraArgs _globalFlags = do-  let verbosity = fromFlag verbosityFlag-  path <- case extraArgs of-    [] -> do cwd <- getCurrentDirectory-             tryFindPackageDesc cwd-    (p:_) -> return p-  pkgDesc <- readGenericPackageDescription verbosity path-  -- Uses 'writeFileAtomic' under the hood.-  writeGenericPackageDescription path pkgDesc--uninstallAction :: Flag Verbosity -> [String] -> Action-uninstallAction verbosityFlag extraArgs _globalFlags = do-  let verbosity = fromFlag verbosityFlag-      package = case extraArgs of-        p:_ -> p-        _   -> "PACKAGE_NAME"-  die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' "-    ++ "operation. "-    ++ "It will likely be implemented at some point in the future; "-    ++ "in the meantime you're advised to use either 'ghc-pkg unregister "-    ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."---sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action-sdistAction (sdistFlags, sdistExFlags) 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--reportAction :: ReportFlags -> [String] -> Action-reportAction reportFlags extraArgs globalFlags = do-  let verbosity = fromFlag (reportVerbosity reportFlags)-  unless (null extraArgs) $-    die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags)-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-      reportFlags' = savedReportFlags config `mappend` reportFlags--  withRepoContext verbosity globalFlags' $ \repoContext ->-   Upload.report verbosity repoContext-    (flagToMaybe $ reportUsername reportFlags')-    (flagToMaybe $ reportPassword reportFlags')--runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action-runAction (buildFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (buildDistPref buildFlags)-  let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck-                    (buildOnly buildExFlags)-  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.-  config' <--    reconfigure configureAction-    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)-    mempty [] globalFlags config-  nixShell verbosity distPref globalFlags config $ do-    lbi <- getPersistBuildConfig distPref-    (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs--    maybeWithSandboxDirOnSearchPath useSandbox $-      build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]--    maybeWithSandboxDirOnSearchPath useSandbox $-      run verbosity lbi exe exeArgs--getAction :: GetFlags -> [String] -> Action-getAction getFlags extraArgs globalFlags = do-  let verbosity = fromFlag (getVerbosity getFlags)-  targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->-   get verbosity-    repoContext-    globalFlags'-    getFlags-    targets--unpackAction :: GetFlags -> [String] -> Action-unpackAction getFlags extraArgs globalFlags = do-  getAction getFlags extraArgs globalFlags--initAction :: InitFlags -> [String] -> Action-initAction initFlags extraArgs globalFlags = do-  let verbosity = fromFlag (initVerbosity initFlags)-  when (extraArgs /= []) $-    die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let configFlags  = savedConfigureFlags config-  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, progdb) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    initCabal verbosity-            (configPackageDB' configFlags)-            repoContext-            comp-            progdb-            initFlags--sandboxAction :: SandboxFlags -> [String] -> Action-sandboxAction sandboxFlags extraArgs globalFlags = do-  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  case extraArgs of-    -- Basic sandbox commands.-    ["init"] -> sandboxInit verbosity sandboxFlags globalFlags-    ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags-    ("add-source":extra) -> do-        when (noExtraArgs extra) $-          die' verbosity "The 'sandbox add-source' command expects at least one argument"-        sandboxAddSource verbosity extra sandboxFlags globalFlags-    ("delete-source":extra) -> do-        when (noExtraArgs extra) $-          die' verbosity ("The 'sandbox delete-source' command expects " ++-              "at least one argument")-        sandboxDeleteSource verbosity extra sandboxFlags globalFlags-    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags--    -- More advanced commands.-    ("hc-pkg":extra) -> do-        when (noExtraArgs extra) $-            die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument"-        sandboxHcPkg verbosity sandboxFlags globalFlags extra-    ["buildopts"] -> die' verbosity "Not implemented!"--    -- Hidden commands.-    ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags--    -- Error handling.-    [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')"-    _  -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs--  where-    noExtraArgs = (<1) . length--execAction :: ExecFlags -> [String] -> Action-execAction execFlags extraArgs globalFlags = do-  let verbosity = fromFlag (execVerbosity execFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (execDistPref execFlags)-  let configFlags = savedConfigureFlags config-      configFlags' = configFlags { configDistPref = Flag distPref }-  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags'-  exec verbosity useSandbox comp platform progdb extraArgs--userConfigAction :: UserConfigFlags -> [String] -> Action-userConfigAction ucflags extraArgs globalFlags = do-  let verbosity = fromFlag (userConfigVerbosity ucflags)-      force     = fromFlag (userConfigForce ucflags)-  case extraArgs of-    ("init":_) -> do-      path       <- configFile-      fileExists <- doesFileExist path-      if (not fileExists || (fileExists && force))-      then void $ createDefaultConfigFile verbosity path-      else die' verbosity $ path ++ " already exists."-    ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags-    ("update":_) -> userConfigUpdate verbosity globalFlags-    -- Error handling.-    [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')"-    _  -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs-  where configFile = getConfigFilePath (globalConfigFile globalFlags)---- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.----win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action-win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do-  let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)-  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse-win32SelfUpgradeAction _ _ _ = return ()---- | Used as an entry point when cabal-install needs to invoke itself--- as a setup script. This can happen e.g. when doing parallel builds.----actAsSetupAction :: ActAsSetupFlags -> [String] -> Action-actAsSetupAction actAsSetupFlags args _globalFlags =-  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)-  in case bt of-    Simple    -> Simple.defaultMainArgs args-    Configure -> Simple.defaultMainWithHooksArgs-                  Simple.autoconfUserHooks args-    Make      -> Make.defaultMainArgs args-    Custom               -> error "actAsSetupAction Custom"-    (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"--manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action-manpageAction commands flagVerbosity extraArgs _ = do-  let verbosity = fromFlag flagVerbosity-  unless (null extraArgs) $-    die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs-  pname <- getProgName-  let cabalCmd = if takeExtension pname == ".exe"-                 then dropExtension pname-                 else pname-  putStrLn $ manpage cabalCmd commands

bootstrap.sh view

@@ -1,4 +1,5 @@ #!/bin/sh+set -e  # A script to bootstrap cabal-install. @@ -208,60 +209,47 @@  # Versions of the packages to install. # The version regex says what existing installed versions are ok.-PARSEC_VER="3.1.11";    PARSEC_VER_REGEXP="[3]\.[01]\."-                       # >= 3.0 && < 3.2+PARSEC_VER="3.1.13.0"; PARSEC_VER_REGEXP="[3]\.[1]\."+                       # >= 3.1 && < 3.2 DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."                        # >= 1.1 && < 2--case "$GHC_VER" in-    7.4*|7.6*)-        # GHC 7.4 or 7.6-        BINARY_VER="0.8.2.1"-        BINARY_VER_REGEXP="[0]\.[78]\.[0-2]\." # >= 0.7 && < 0.8.3-        ;;-    *)-        # GHC >= 7.8-        BINARY_VER="0.8.5.1"-        BINARY_VER_REGEXP="[0]\.[78]\." # >= 0.7 && < 0.9-        ;;-esac---TEXT_VER="1.2.2.2";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"-                       # >= 0.2 && < 1.3-NETWORK_VER="2.6.3.2"; NETWORK_VER_REGEXP="2\.[0-6]\."+BINARY_VER="0.8.3.0";  BINARY_VER_REGEXP="[0]\.[78]\."+                       # >= 0.7 && < 0.9+TEXT_VER="1.2.3.0";    TEXT_VER_REGEXP="[1]\.[2]\."+                       # >= 1.2 && < 1.3+NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\.(0\.[2-9]|[1-9])"+                       # >= 2.6.0.2 && < 2.7+NETWORK_VER="2.6.3.4"; NETWORK_VER_REGEXP="2\.[0-6]\."                        # >= 2.0 && < 2.7-NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\."-                       # >= 2.6 && < 2.7-CABAL_VER="2.0.1.0";  CABAL_VER_REGEXP="2\.0\.[0-9]"-                       # >= 2.0 && < 2.1-TRANS_VER="0.5.4.0";   TRANS_VER_REGEXP="0\.[45]\."+CABAL_VER="2.2.0.1";   CABAL_VER_REGEXP="2\.2\.[0-9]"+                       # >= 2.2 && < 2.3+TRANS_VER="0.5.5.0";   TRANS_VER_REGEXP="0\.[45]\."                        # >= 0.2.* && < 0.6-MTL_VER="2.2.1";       MTL_VER_REGEXP="[2]\."+MTL_VER="2.2.2";       MTL_VER_REGEXP="[2]\."                        #  >= 2.0 && < 3-HTTP_VER="4000.3.7";   HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"+HTTP_VER="4000.3.11";  HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"                        # >= 4000.2.5 < 4000.4-ZLIB_VER="0.6.1.2";    ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)"+ZLIB_VER="0.6.2";      ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)"                        # >= 0.5.3 && <= 0.7-TIME_VER="1.8.0.2"     TIME_VER_REGEXP="1\.[1-8]\.?"+TIME_VER="1.8.0.3"     TIME_VER_REGEXP="1\.[1-8]\.?"                        # >= 1.1 && < 1.9 RANDOM_VER="1.1"       RANDOM_VER_REGEXP="1\.[01]\.?"                        # >= 1 && < 1.2-STM_VER="2.4.4.1";     STM_VER_REGEXP="2\."+STM_VER="2.4.5.0";     STM_VER_REGEXP="2\."                        # == 2.*-ASYNC_VER="2.1.1.1";   ASYNC_VER_REGEXP="2\."+HASHABLE_VER="1.2.7.0"; HASHABLE_VER_REGEXP="1\."+                       # 1.*+ASYNC_VER="2.2.1";     ASYNC_VER_REGEXP="2\."                        # 2.*-OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?"-                       # >=1.0.0.0 && <1.2-OLD_LOCALE_VER="1.0.0.7"; OLD_LOCALE_VER_REGEXP="1\.0\.?"-                       # >=1.0.0.0 && <1.1 BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1"                        # 0.1.* BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\."                        # >=1.0-CRYPTOHASH_SHA256_VER="0.11.100.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?"+CRYPTOHASH_SHA256_VER="0.11.101.0"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?"                        # 0.11.*-MINTTY_VER="0.1";      MINTTY_VER_REGEXP="0\.1\.?"+RESOLV_VER="0.1.1.1";  RESOLV_VER_REGEXP="0\.1\.[1-9]"+                       # >= 0.1.1 && < 0.2+MINTTY_VER="0.1.1";    MINTTY_VER_REGEXP="0\.1\.?"                        # 0.1.* ECHO_VER="0.1.3";      ECHO_VER_REGEXP="0\.1\.[3-9]"                        # >= 0.1.3 && < 0.2@@ -269,19 +257,16 @@                        # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?"                        # 0.0.*-HACKAGE_SECURITY_VER="0.5.2.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.(2\.[2-9]|[3-9])"+HACKAGE_SECURITY_VER="0.5.3.0"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.((2\.[2-9]|[3-9])|3)"                        # >= 0.5.2 && < 0.6-BYTESTRING_BUILDER_VER="0.10.8.1.0"; BYTESTRING_BUILDER_VER_REGEXP="0\.10\.?"-TAR_VER="0.5.0.3";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?"+TAR_VER="0.5.1.0";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?"                        # >= 0.5.0.3  && < 0.6-HASHABLE_VER="1.2.6.1"; HASHABLE_VER_REGEXP="1\."-                       # 1.*  HACKAGE_URL="https://hackage.haskell.org/package" -# Haddock fails for network-2.5.0.0, and for hackage-security for-# GHC <8, c.f. https://github.com/well-typed/hackage-security/issues/149-NO_DOCS_PACKAGES_VER_REGEXP="network-uri-2\.5\.[0-9]+\.[0-9]+|hackage-security-0\.5\.[0-9]+\.[0-9]+"+# Haddock fails for hackage-security for GHC <8,+# c.f. https://github.com/well-typed/hackage-security/issues/149+NO_DOCS_PACKAGES_VER_REGEXP="hackage-security-0\.5\.[0-9]+\.[0-9]+"  # Cache the list of packages: echo "Checking installed packages for ghc-${GHC_VER}..."@@ -327,11 +312,8 @@   URL_PKGDESC=${HACKAGE_URL}/${PKG}-${VER}/${PKG}.cabal   if which ${CURL} > /dev/null   then-    # TODO: switch back to resuming curl command once-    #       https://github.com/haskell/hackage-server/issues/111 is resolved-    #${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}."-    ${CURL} -L --fail -O ${URL_PKG} || die "Failed to download ${PKG}."-    ${CURL} -L --fail -O ${URL_PKGDESC} \+    ${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -C - -O ${URL_PKGDESC} \         || die "Failed to download '${PKG}.cabal'."   elif which ${WGET} > /dev/null   then@@ -368,7 +350,12 @@   [ -x Setup ] && ./Setup clean   [ -f Setup ] && rm Setup -  ${GHC} --make ${JOBS} Setup -o Setup -XRank2Types -XFlexibleContexts ||+  PKG_DBS=$(printf '%s\n' "${SCOPE_OF_INSTALLATION}" \+             | sed -e 's/--package-db/-package-db/' \+                   -e 's/--global/-global-package-db/' \+                   -e 's/--user/-user-package-db/')++  ${GHC} --make ${JOBS} ${PKG_DBS} Setup -o Setup -XRank2Types -XFlexibleContexts ||     die "Compiling the Setup script failed."    [ -x Setup ] || die "The Setup script does not exist or cannot be run"@@ -436,38 +423,6 @@     fi } -# Replicate the flag selection logic for network-uri in the .cabal file.-do_network_uri_pkg () {-  # Refresh installed package list.-  ${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg-stage2.list \-    || die "running '${GHC_PKG} list' failed"--  NETWORK_URI_DUMMY_VER="2.5.0.0"; NETWORK_URI_DUMMY_VER_REGEXP="2\.5\." # < 2.6-  if egrep " network-2\.[6-9]\." ghc-pkg-stage2.list > /dev/null 2>&1-  then-    # Use network >= 2.6 && network-uri >= 2.6-    info_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}-    do_pkg   "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}-  else-    # Use network < 2.6 && network-uri < 2.6-    info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} \-        ${NETWORK_URI_DUMMY_VER_REGEXP}-    do_pkg   "network-uri" ${NETWORK_URI_DUMMY_VER} \-        ${NETWORK_URI_DUMMY_VER_REGEXP}-  fi-}--# Conditionally install bytestring-builder if bytestring is < 0.10.2.-do_bytestring_builder_pkg () {-  if egrep "bytestring-0\.(9|10\.[0,1])\.?" ghc-pkg-stage2.list > /dev/null 2>&1-  then-      info_pkg "bytestring-builder" ${BYTESTRING_BUILDER_VER} \-               ${BYTESTRING_BUILDER_VER_REGEXP}-      do_pkg   "bytestring-builder" ${BYTESTRING_BUILDER_VER} \-               ${BYTESTRING_BUILDER_VER_REGEXP}-  fi-}- # Actually do something!  info_pkg "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP}@@ -477,13 +432,13 @@ info_pkg "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP} info_pkg "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP}+info_pkg "network-uri"  ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}-info_pkg "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}-info_pkg "old-time"     ${OLD_TIME_VER}   ${OLD_TIME_VER_REGEXP} info_pkg "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} info_pkg "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} info_pkg "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP} info_pkg "stm"          ${STM_VER}     ${STM_VER_REGEXP}+info_pkg "hashable"     ${HASHABLE_VER}  ${HASHABLE_VER_REGEXP} info_pkg "async"        ${ASYNC_VER}   ${ASYNC_VER_REGEXP} info_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \     ${BASE16_BYTESTRING_VER_REGEXP}@@ -491,12 +446,12 @@     ${BASE64_BYTESTRING_VER_REGEXP} info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \     ${CRYPTOHASH_SHA256_VER_REGEXP}+info_pkg "resolv"        ${RESOLV_VER}        ${RESOLV_VER_REGEXP} info_pkg "mintty"        ${MINTTY_VER}        ${MINTTY_VER_REGEXP} info_pkg "echo"          ${ECHO_VER}          ${ECHO_VER_REGEXP} info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} info_pkg "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP} info_pkg "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}-info_pkg "hashable"          ${HASHABLE_VER}         ${HASHABLE_VER_REGEXP} info_pkg "hackage-security"  ${HACKAGE_SECURITY_VER} \     ${HACKAGE_SECURITY_VER_REGEXP} @@ -504,24 +459,22 @@ do_pkg   "binary"       ${BINARY_VER}  ${BINARY_VER_REGEXP} do_pkg   "time"         ${TIME_VER}    ${TIME_VER_REGEXP} -# Install the Cabal library from the local Git clone if possible.-do_Cabal_pkg-+# Cabal might depend on these do_pkg   "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP} do_pkg   "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP} do_pkg   "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} do_pkg   "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP}-do_pkg   "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP} -# We conditionally install network-uri, depending on the network version.-do_network_uri_pkg+# Install the Cabal library from the local Git clone if possible.+do_Cabal_pkg -do_pkg   "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}-do_pkg   "old-time"     ${OLD_TIME_VER}   ${OLD_TIME_VER_REGEXP}+do_pkg   "network-uri"  ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}+do_pkg   "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP} do_pkg   "HTTP"         ${HTTP_VER}       ${HTTP_VER_REGEXP} do_pkg   "zlib"         ${ZLIB_VER}       ${ZLIB_VER_REGEXP} do_pkg   "random"       ${RANDOM_VER}     ${RANDOM_VER_REGEXP} do_pkg   "stm"          ${STM_VER}        ${STM_VER_REGEXP}+do_pkg   "hashable"     ${HASHABLE_VER}   ${HASHABLE_VER_REGEXP} do_pkg   "async"        ${ASYNC_VER}      ${ASYNC_VER_REGEXP} do_pkg   "base16-bytestring" ${BASE16_BYTESTRING_VER} \     ${BASE16_BYTESTRING_VER_REGEXP}@@ -529,17 +482,12 @@     ${BASE64_BYTESTRING_VER_REGEXP} do_pkg   "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \     ${CRYPTOHASH_SHA256_VER_REGEXP}+do_pkg "resolv"        ${RESOLV_VER}        ${RESOLV_VER_REGEXP} do_pkg "mintty"        ${MINTTY_VER}        ${MINTTY_VER_REGEXP} do_pkg "echo"          ${ECHO_VER}          ${ECHO_VER_REGEXP} do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} do_pkg   "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}--# We conditionally install bytestring-builder, depending on the bytestring-# version.-do_bytestring_builder_pkg- do_pkg   "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}-do_pkg   "hashable"          ${HASHABLE_VER}         ${HASHABLE_VER_REGEXP} do_pkg   "hackage-security"  ${HACKAGE_SECURITY_VER} \     ${HACKAGE_SECURITY_VER_REGEXP}

cabal-install.cabal view

@@ -1,17 +1,20 @@ Name:               cabal-install-Version:            2.0.0.1+Version:            2.2.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing     Haskell software by automating the fetching, configuration, compilation     and installation of Haskell libraries and programs.+    .+    This package only provides an executable and cannot be used as a+    library (ignore the module listing below.) homepage:           http://www.haskell.org/cabal/ bug-reports:        https://github.com/haskell/cabal/issues License:            BSD3 License-File:       LICENSE Author:             Cabal Development Team (see AUTHORS file) Maintainer:         Cabal Development Team <cabal-devel@haskell.org>-Copyright:          2003-2017, Cabal Development Team+Copyright:          2003-2018, Cabal Development Team Category:           Distribution Build-type:         Custom Cabal-Version:      >= 1.10@@ -19,7 +22,7 @@   README.md bash-completion/cabal bootstrap.sh changelog   tests/README.md -  -- Generated with '../Cabal/misc/gen-extra-source-files.sh'+  -- Generated with 'make gen-extra-source-files'   -- Do NOT edit this section manually; instead, run the script.   -- BEGIN gen-extra-source-files   tests/IntegrationTests2/build/keep-going/cabal.project@@ -62,6 +65,7 @@   tests/IntegrationTests2/targets/exes-disabled/cabal.project   tests/IntegrationTests2/targets/exes-disabled/p/p.cabal   tests/IntegrationTests2/targets/exes-disabled/q/q.cabal+  tests/IntegrationTests2/targets/lib-only/p.cabal   tests/IntegrationTests2/targets/libs-disabled/cabal.project   tests/IntegrationTests2/targets/libs-disabled/p/p.cabal   tests/IntegrationTests2/targets/libs-disabled/q/q.cabal@@ -90,17 +94,10 @@   location: https://github.com/haskell/cabal/   subdir:   cabal-install -Flag old-bytestring-  description:  Use bytestring < 0.10.2 and bytestring-builder-  default: False--Flag old-directory-  description:  Use directory < 1.2 and old-time-  default:      False--Flag network-uri-  description:  Get Network.URI from the network-uri package+Flag native-dns+  description:  Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups   default:      True+  manual:       True  Flag debug-expensive-assertions   description:  Enable expensive assertions for testing or debugging@@ -117,32 +114,32 @@   default:      False   manual:       True -flag parsec-  description:  Use parsec parser. This requires 'Cabal' library built with its parsec flag enabled.-  default:      False+flag lib+  description:  Build cabal-install as a library. Please only use this if you are a cabal-install developer.+  Default:      False   manual:       True --- When we do CI, we build our binaries on one machine, and then--- ship them to another machine for testing.  Because we use--- static linking (since it makes this sort of redeploy MUCH--- easier), if we build five executables, that means we--- need to ship ALL the Haskell libraries five times.  That's--- a waste of space!  A better strategy is to statically link--- everything into a single binary.  That's what this flag does.+-- Build everything (including the test binaries) as a single static binary+-- instead of 5 discrete binaries.+-- This is useful for CI where we build our binaries on one machine, and then+-- ship them to another machine for testing.  Since the test binaries are+-- statically linked (making deployment easier), if we build five executables,+-- that means we need to ship ALL 5 binaries (with 5 versions of all the+-- statically linked libraries) to the test machines. This reduces that to one+-- binary and one set of linked libraries. flag monolithic   description:  Build cabal-install also with all of its test and support code.  Used by our continuous integration.   default:      False   manual:       True -executable cabal-    main-is:        Main.hs-    ghc-options:    -Wall -fwarn-tabs -rtsopts+library+    ghc-options:    -Wall -fwarn-tabs     if impl(ghc >= 8.0)         ghc-options: -Wcompat                      -Wnoncanonical-monad-instances                      -Wnoncanonical-monadfail-instances -    other-modules:+    exposed-modules:         Distribution.Client.BuildReports.Anonymous         Distribution.Client.BuildReports.Storage         Distribution.Client.BuildReports.Types@@ -151,12 +148,22 @@         Distribution.Client.CmdBench         Distribution.Client.CmdBuild         Distribution.Client.CmdConfigure+        Distribution.Client.CmdUpdate+        Distribution.Client.CmdErrorMessages+        Distribution.Client.CmdExec         Distribution.Client.CmdFreeze         Distribution.Client.CmdHaddock+        Distribution.Client.CmdInstall         Distribution.Client.CmdRepl         Distribution.Client.CmdRun         Distribution.Client.CmdTest-        Distribution.Client.CmdErrorMessages+        Distribution.Client.Compat.Directory+        Distribution.Client.Compat.ExecutablePath+        Distribution.Client.Compat.FileLock+        Distribution.Client.Compat.FilePerms+        Distribution.Client.Compat.Prelude+        Distribution.Client.Compat.Process+        Distribution.Client.Compat.Semaphore         Distribution.Client.Config         Distribution.Client.Configure         Distribution.Client.Dependency@@ -167,11 +174,11 @@         Distribution.Client.FetchUtils         Distribution.Client.FileMonitor         Distribution.Client.Freeze+        Distribution.Client.GZipUtils         Distribution.Client.GenBounds         Distribution.Client.Get         Distribution.Client.Glob         Distribution.Client.GlobalFlags-        Distribution.Client.GZipUtils         Distribution.Client.Haddock         Distribution.Client.HttpUtils         Distribution.Client.IndexUtils@@ -194,12 +201,12 @@         Distribution.Client.ProjectBuilding         Distribution.Client.ProjectBuilding.Types         Distribution.Client.ProjectConfig-        Distribution.Client.ProjectConfig.Types         Distribution.Client.ProjectConfig.Legacy+        Distribution.Client.ProjectConfig.Types         Distribution.Client.ProjectOrchestration+        Distribution.Client.ProjectPlanOutput         Distribution.Client.ProjectPlanning         Distribution.Client.ProjectPlanning.Types-        Distribution.Client.ProjectPlanOutput         Distribution.Client.RebuildMonad         Distribution.Client.Reconfigure         Distribution.Client.Run@@ -213,48 +220,23 @@         Distribution.Client.Security.HTTP         Distribution.Client.Setup         Distribution.Client.SetupWrapper-        Distribution.Client.SrcDist         Distribution.Client.SolverInstallPlan         Distribution.Client.SourceFiles+        Distribution.Client.SourceRepoParse+        Distribution.Client.SrcDist         Distribution.Client.Store         Distribution.Client.Tar-        Distribution.Client.Targets         Distribution.Client.TargetSelector+        Distribution.Client.Targets         Distribution.Client.Types         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils         Distribution.Client.Utils.Assertion         Distribution.Client.Utils.Json-        Distribution.Client.World         Distribution.Client.Win32SelfUpgrade-        Distribution.Client.Compat.ExecutablePath-        Distribution.Client.Compat.FileLock-        Distribution.Client.Compat.FilePerms-        Distribution.Client.Compat.Prelude-        Distribution.Client.Compat.Process-        Distribution.Client.Compat.Semaphore-        Distribution.Solver.Types.ComponentDeps-        Distribution.Solver.Types.ConstraintSource-        Distribution.Solver.Types.DependencyResolver-        Distribution.Solver.Types.Flag-        Distribution.Solver.Types.InstalledPreference-        Distribution.Solver.Types.InstSolverPackage-        Distribution.Solver.Types.LabeledPackageConstraint-        Distribution.Solver.Types.OptionalStanza-        Distribution.Solver.Types.PackageConstraint-        Distribution.Solver.Types.PackageFixedDeps-        Distribution.Solver.Types.PackageIndex-        Distribution.Solver.Types.PackagePath-        Distribution.Solver.Types.PackagePreferences-        Distribution.Solver.Types.PkgConfigDb-        Distribution.Solver.Types.Progress-        Distribution.Solver.Types.ResolverPackage-        Distribution.Solver.Types.Settings-        Distribution.Solver.Types.SolverId-        Distribution.Solver.Types.SolverPackage-        Distribution.Solver.Types.SourcePackage-        Distribution.Solver.Types.Variable+        Distribution.Client.World+        Distribution.Solver.Compat.Prelude         Distribution.Solver.Modular         Distribution.Solver.Modular.Assignment         Distribution.Solver.Modular.Builder@@ -267,13 +249,13 @@         Distribution.Solver.Modular.Flag         Distribution.Solver.Modular.Index         Distribution.Solver.Modular.IndexConversion-        Distribution.Solver.Modular.Linking         Distribution.Solver.Modular.LabeledGraph+        Distribution.Solver.Modular.Linking         Distribution.Solver.Modular.Log         Distribution.Solver.Modular.Message+        Distribution.Solver.Modular.PSQ         Distribution.Solver.Modular.Package         Distribution.Solver.Modular.Preference-        Distribution.Solver.Modular.PSQ         Distribution.Solver.Modular.RetryLog         Distribution.Solver.Modular.Solver         Distribution.Solver.Modular.Tree@@ -281,6 +263,27 @@         Distribution.Solver.Modular.Var         Distribution.Solver.Modular.Version         Distribution.Solver.Modular.WeightedPSQ+        Distribution.Solver.Types.ComponentDeps+        Distribution.Solver.Types.ConstraintSource+        Distribution.Solver.Types.DependencyResolver+        Distribution.Solver.Types.Flag+        Distribution.Solver.Types.InstSolverPackage+        Distribution.Solver.Types.InstalledPreference+        Distribution.Solver.Types.LabeledPackageConstraint+        Distribution.Solver.Types.OptionalStanza+        Distribution.Solver.Types.PackageConstraint+        Distribution.Solver.Types.PackageFixedDeps+        Distribution.Solver.Types.PackageIndex+        Distribution.Solver.Types.PackagePath+        Distribution.Solver.Types.PackagePreferences+        Distribution.Solver.Types.PkgConfigDb+        Distribution.Solver.Types.Progress+        Distribution.Solver.Types.ResolverPackage+        Distribution.Solver.Types.Settings+        Distribution.Solver.Types.SolverId+        Distribution.Solver.Types.SolverPackage+        Distribution.Solver.Types.SourcePackage+        Distribution.Solver.Types.Variable         Paths_cabal_install      -- NOTE: when updating build-depends, don't forget to update version regexps@@ -290,19 +293,23 @@         array      >= 0.4      && < 0.6,         base       >= 4.5      && < 5,         base16-bytestring >= 0.1.1 && < 0.2,-        binary     >= 0.5      && < 0.9,-        bytestring >= 0.9      && < 1,-        Cabal      >= 2.0      && < 2.1,+        binary     >= 0.7      && < 0.9,+        bytestring >= 0.10.2   && < 1,+        Cabal      >= 2.2      && < 2.3,         containers >= 0.4      && < 0.6,         cryptohash-sha256 >= 0.11 && < 0.12,         deepseq    >= 1.3      && < 1.5,+        directory  >= 1.2.2.0  && < 1.4,         echo       >= 0.1.3    && < 0.2,         edit-distance >= 0.2.2 && < 0.3,         filepath   >= 1.3      && < 1.5,         hashable   >= 1.0      && < 2,         HTTP       >= 4000.1.5 && < 4000.4,         mtl        >= 2.0      && < 3,+        network-uri >= 2.6.0.2 && < 2.7,+        network    >= 2.6      && < 2.7,         pretty     >= 1.1      && < 1.2,+        process    >= 1.1.0.2  && < 1.7,         random     >= 1        && < 1.2,         stm        >= 2.0      && < 3,         tar        >= 0.5.0.3  && < 0.6,@@ -310,42 +317,17 @@         zlib       >= 0.5.3    && < 0.7,         hackage-security >= 0.5.2.2 && < 0.6 -    if flag(old-bytestring)-      build-depends: bytestring <  0.10.2, bytestring-builder >= 0.10 && < 1-    else-      build-depends: bytestring >= 0.10.2--    if flag(old-directory)-      build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2,-                     process   >= 1.0.1.1  && < 1.1.0.2-    else-      build-depends: directory >= 1.2 && < 1.4,-                     process   >= 1.1.0.2  && < 1.7--    -- NOTE: you MUST include the network dependency even when network-uri-    -- is pulled in, otherwise the constraint solver doesn't have enough-    -- information-    if flag(network-uri)-      build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6 && < 2.7-    else-      build-depends: network     >= 2.4 && < 2.6--    -- Needed for GHC.Generics before GHC 7.6-    if impl(ghc < 7.6)-      build-depends: ghc-prim >= 0.2 && < 0.3+    if flag(native-dns)+      if os(windows)+        build-depends: windns      >= 0.1.0 && < 0.2+      else+        build-depends: resolv      >= 0.1.1 && < 0.2      if os(windows)       build-depends: Win32 >= 2 && < 3     else       build-depends: unix >= 2.5 && < 2.8 -    if !(arch(arm) && impl(ghc < 7.6))-      ghc-options: -threaded--    -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a-    if os(aix)-      extra-libraries: bsd-     if flag(debug-expensive-assertions)       cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS @@ -357,14 +339,237 @@       cpp-options: -DDEBUG_TRACETREE       build-depends: tracetree >= 0.1 && < 0.2 -    if flag(parsec)-      cpp-options: -DCABAL_PARSEC+    if !flag(lib)+      buildable: False -    hs-source-dirs: .+    default-language: Haskell2010++executable cabal+    main-is:        Main.hs+    hs-source-dirs: main++    ghc-options:    -Wall -fwarn-tabs -rtsopts+    if impl(ghc >= 8.0)+        ghc-options: -Wcompat+                     -Wnoncanonical-monad-instances+                     -Wnoncanonical-monadfail-instances++    other-modules: Paths_cabal_install++    if flag(lib)+        build-depends:+            cabal-install,+            Cabal      >= 2.2      && < 2.3,+            base,+            directory,+            filepath+    else+        hs-source-dirs: .+        build-depends:+            async      >= 2.0      && < 3,+            array      >= 0.4      && < 0.6,+            base       >= 4.5      && < 5,+            base16-bytestring >= 0.1.1 && < 0.2,+            binary     >= 0.7      && < 0.9,+            bytestring >= 0.10.2   && < 1,+            Cabal      >= 2.2      && < 2.3,+            containers >= 0.4      && < 0.6,+            cryptohash-sha256 >= 0.11 && < 0.12,+            deepseq    >= 1.3      && < 1.5,+            directory  >= 1.2.2.0  && < 1.4,+            echo       >= 0.1.3    && < 0.2,+            edit-distance >= 0.2.2 && < 0.3,+            filepath   >= 1.3      && < 1.5,+            hashable   >= 1.0      && < 2,+            HTTP       >= 4000.1.5 && < 4000.4,+            mtl        >= 2.0      && < 3,+            network    >= 2.6      && < 2.7,+            network-uri >= 2.6     && < 2.7,+            pretty     >= 1.1      && < 1.2,+            process    >= 1.2      && < 1.7,+            random     >= 1        && < 1.2,+            stm        >= 2.0      && < 3,+            tar        >= 0.5.0.3  && < 0.6,+            time       >= 1.4      && < 1.9,+            zlib       >= 0.5.3    && < 0.7,+            hackage-security >= 0.5.2.2 && < 0.6++        other-modules:+            Distribution.Client.BuildReports.Anonymous+            Distribution.Client.BuildReports.Storage+            Distribution.Client.BuildReports.Types+            Distribution.Client.BuildReports.Upload+            Distribution.Client.Check+            Distribution.Client.CmdBench+            Distribution.Client.CmdBuild+            Distribution.Client.CmdConfigure+            Distribution.Client.CmdUpdate+            Distribution.Client.CmdErrorMessages+            Distribution.Client.CmdExec+            Distribution.Client.CmdFreeze+            Distribution.Client.CmdHaddock+            Distribution.Client.CmdInstall+            Distribution.Client.CmdRepl+            Distribution.Client.CmdRun+            Distribution.Client.CmdTest+            Distribution.Client.Compat.Directory+            Distribution.Client.Compat.ExecutablePath+            Distribution.Client.Compat.FileLock+            Distribution.Client.Compat.FilePerms+            Distribution.Client.Compat.Prelude+            Distribution.Client.Compat.Process+            Distribution.Client.Compat.Semaphore+            Distribution.Client.Config+            Distribution.Client.Configure+            Distribution.Client.Dependency+            Distribution.Client.Dependency.Types+            Distribution.Client.DistDirLayout+            Distribution.Client.Exec+            Distribution.Client.Fetch+            Distribution.Client.FetchUtils+            Distribution.Client.FileMonitor+            Distribution.Client.Freeze+            Distribution.Client.GZipUtils+            Distribution.Client.GenBounds+            Distribution.Client.Get+            Distribution.Client.Glob+            Distribution.Client.GlobalFlags+            Distribution.Client.Haddock+            Distribution.Client.HttpUtils+            Distribution.Client.IndexUtils+            Distribution.Client.IndexUtils.Timestamp+            Distribution.Client.Init+            Distribution.Client.Init.Heuristics+            Distribution.Client.Init.Licenses+            Distribution.Client.Init.Types+            Distribution.Client.Install+            Distribution.Client.InstallPlan+            Distribution.Client.InstallSymlink+            Distribution.Client.JobControl+            Distribution.Client.List+            Distribution.Client.Manpage+            Distribution.Client.Nix+            Distribution.Client.Outdated+            Distribution.Client.PackageHash+            Distribution.Client.PackageUtils+            Distribution.Client.ParseUtils+            Distribution.Client.ProjectBuilding+            Distribution.Client.ProjectBuilding.Types+            Distribution.Client.ProjectConfig+            Distribution.Client.ProjectConfig.Legacy+            Distribution.Client.ProjectConfig.Types+            Distribution.Client.ProjectOrchestration+            Distribution.Client.ProjectPlanOutput+            Distribution.Client.ProjectPlanning+            Distribution.Client.ProjectPlanning.Types+            Distribution.Client.RebuildMonad+            Distribution.Client.Reconfigure+            Distribution.Client.Run+            Distribution.Client.Sandbox+            Distribution.Client.Sandbox.Index+            Distribution.Client.Sandbox.PackageEnvironment+            Distribution.Client.Sandbox.Timestamp+            Distribution.Client.Sandbox.Types+            Distribution.Client.SavedFlags+            Distribution.Client.Security.DNS+            Distribution.Client.Security.HTTP+            Distribution.Client.Setup+            Distribution.Client.SetupWrapper+            Distribution.Client.SolverInstallPlan+            Distribution.Client.SourceFiles+            Distribution.Client.SourceRepoParse+            Distribution.Client.SrcDist+            Distribution.Client.Store+            Distribution.Client.Tar+            Distribution.Client.TargetSelector+            Distribution.Client.Targets+            Distribution.Client.Types+            Distribution.Client.Update+            Distribution.Client.Upload+            Distribution.Client.Utils+            Distribution.Client.Utils.Assertion+            Distribution.Client.Utils.Json+            Distribution.Client.Win32SelfUpgrade+            Distribution.Client.World+            Distribution.Solver.Compat.Prelude+            Distribution.Solver.Modular+            Distribution.Solver.Modular.Assignment+            Distribution.Solver.Modular.Builder+            Distribution.Solver.Modular.Configured+            Distribution.Solver.Modular.ConfiguredConversion+            Distribution.Solver.Modular.ConflictSet+            Distribution.Solver.Modular.Cycles+            Distribution.Solver.Modular.Dependency+            Distribution.Solver.Modular.Explore+            Distribution.Solver.Modular.Flag+            Distribution.Solver.Modular.Index+            Distribution.Solver.Modular.IndexConversion+            Distribution.Solver.Modular.LabeledGraph+            Distribution.Solver.Modular.Linking+            Distribution.Solver.Modular.Log+            Distribution.Solver.Modular.Message+            Distribution.Solver.Modular.PSQ+            Distribution.Solver.Modular.Package+            Distribution.Solver.Modular.Preference+            Distribution.Solver.Modular.RetryLog+            Distribution.Solver.Modular.Solver+            Distribution.Solver.Modular.Tree+            Distribution.Solver.Modular.Validate+            Distribution.Solver.Modular.Var+            Distribution.Solver.Modular.Version+            Distribution.Solver.Modular.WeightedPSQ+            Distribution.Solver.Types.ComponentDeps+            Distribution.Solver.Types.ConstraintSource+            Distribution.Solver.Types.DependencyResolver+            Distribution.Solver.Types.Flag+            Distribution.Solver.Types.InstSolverPackage+            Distribution.Solver.Types.InstalledPreference+            Distribution.Solver.Types.LabeledPackageConstraint+            Distribution.Solver.Types.OptionalStanza+            Distribution.Solver.Types.PackageConstraint+            Distribution.Solver.Types.PackageFixedDeps+            Distribution.Solver.Types.PackageIndex+            Distribution.Solver.Types.PackagePath+            Distribution.Solver.Types.PackagePreferences+            Distribution.Solver.Types.PkgConfigDb+            Distribution.Solver.Types.Progress+            Distribution.Solver.Types.ResolverPackage+            Distribution.Solver.Types.Settings+            Distribution.Solver.Types.SolverId+            Distribution.Solver.Types.SolverPackage+            Distribution.Solver.Types.SourcePackage+            Distribution.Solver.Types.Variable++        if flag(native-dns)+          if os(windows)+            build-depends: windns      >= 0.1.0 && < 0.2+          else+            build-depends: resolv      >= 0.1.1 && < 0.2++        if os(windows)+          build-depends: Win32 >= 2 && < 3+        else+          build-depends: unix >= 2.5 && < 2.8++        if flag(debug-expensive-assertions)+          cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS++        if flag(debug-conflict-sets)+          cpp-options: -DDEBUG_CONFLICT_SETS+          build-depends: base >= 4.8++        if flag(debug-tracetree)+          cpp-options: -DDEBUG_TRACETREE+          build-depends: tracetree >= 0.1 && < 0.2+     if flag(monolithic)       hs-source-dirs: tests       other-modules:         UnitTests+        MemoryUsageTests+        SolverQuickCheck+        IntegrationTests2+         UnitTests.Distribution.Client.ArbitraryInstances         UnitTests.Distribution.Client.FileMonitor         UnitTests.Distribution.Client.GZipUtils@@ -379,21 +584,20 @@         UnitTests.Distribution.Client.Tar         UnitTests.Distribution.Client.Targets         UnitTests.Distribution.Client.UserConfig+        UnitTests.Distribution.Solver.Modular.Builder         UnitTests.Distribution.Solver.Modular.DSL         UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils         UnitTests.Distribution.Solver.Modular.MemoryUsage-        UnitTests.Distribution.Solver.Modular.PSQ         UnitTests.Distribution.Solver.Modular.QuickCheck+        UnitTests.Distribution.Solver.Modular.QuickCheck.Utils         UnitTests.Distribution.Solver.Modular.RetryLog         UnitTests.Distribution.Solver.Modular.Solver         UnitTests.Distribution.Solver.Modular.WeightedPSQ         UnitTests.Options-        MemoryUsageTests-        SolverQuickCheck-        IntegrationTests2+       cpp-options: -DMONOLITHIC       build-depends:-        Cabal      >= 2.0 && < 2.1,+        Cabal      >= 2.2 && < 2.3,         QuickCheck >= 2.8.2,         array,         async,@@ -403,210 +607,84 @@         directory,         edit-distance,         filepath,+        hashable,         mtl,         network,         network-uri,-        pretty-show,+        pretty-show >= 1.6.15,         random,         tagged,         tar,-        tasty >= 0.12,+        tasty >= 1.0 && < 1.1,         tasty-hunit >= 0.10,         tasty-quickcheck,         time,         zlib +    ghc-options: -threaded++    -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a+    if os(aix)+      extra-libraries: bsd+     default-language: Haskell2010  -- Small, fast running tests. Test-Suite unit-tests   type: exitcode-stdio-1.0   main-is: UnitTests.hs-  hs-source-dirs: tests, .+  hs-source-dirs: tests   ghc-options: -Wall -fwarn-tabs -main-is UnitTests   other-modules:-    Distribution.Client.BuildReports.Anonymous-    Distribution.Client.BuildReports.Storage-    Distribution.Client.BuildReports.Types-    Distribution.Client.Compat.ExecutablePath-    Distribution.Client.Compat.FileLock-    Distribution.Client.Compat.FilePerms-    Distribution.Client.Compat.Prelude-    Distribution.Client.Compat.Semaphore-    Distribution.Client.Config-    Distribution.Client.Configure-    Distribution.Client.Dependency-    Distribution.Client.Dependency.Types-    Distribution.Client.DistDirLayout-    Distribution.Client.FetchUtils-    Distribution.Client.FileMonitor-    Distribution.Client.GZipUtils-    Distribution.Client.Glob-    Distribution.Client.GlobalFlags-    Distribution.Client.Haddock-    Distribution.Client.HttpUtils-    Distribution.Client.IndexUtils-    Distribution.Client.IndexUtils.Timestamp-    Distribution.Client.Init.Types-    Distribution.Client.Install-    Distribution.Client.InstallPlan-    Distribution.Client.InstallSymlink-    Distribution.Client.JobControl-    Distribution.Client.PackageUtils-    Distribution.Client.ParseUtils-    Distribution.Client.ProjectConfig-    Distribution.Client.ProjectConfig.Legacy-    Distribution.Client.ProjectConfig.Types-    Distribution.Client.RebuildMonad-    Distribution.Client.Sandbox-    Distribution.Client.Sandbox.Index-    Distribution.Client.Sandbox.PackageEnvironment-    Distribution.Client.Sandbox.Timestamp-    Distribution.Client.Sandbox.Types-    Distribution.Client.SavedFlags-    Distribution.Client.Security.DNS-    Distribution.Client.Security.HTTP-    Distribution.Client.Setup-    Distribution.Client.SetupWrapper-    Distribution.Client.SolverInstallPlan-    Distribution.Client.SrcDist-    Distribution.Client.Store-    Distribution.Client.Tar-    Distribution.Client.Targets-    Distribution.Client.Types-    Distribution.Client.Utils-    Distribution.Client.Utils.Assertion-    Distribution.Client.Win32SelfUpgrade-    Distribution.Client.World-    Distribution.Solver.Modular-    Distribution.Solver.Modular.Assignment-    Distribution.Solver.Modular.Builder-    Distribution.Solver.Modular.Configured-    Distribution.Solver.Modular.ConfiguredConversion-    Distribution.Solver.Modular.ConflictSet-    Distribution.Solver.Modular.Cycles-    Distribution.Solver.Modular.Dependency-    Distribution.Solver.Modular.Explore-    Distribution.Solver.Modular.Flag-    Distribution.Solver.Modular.Index-    Distribution.Solver.Modular.IndexConversion-    Distribution.Solver.Modular.LabeledGraph-    Distribution.Solver.Modular.Linking-    Distribution.Solver.Modular.Log-    Distribution.Solver.Modular.Message-    Distribution.Solver.Modular.PSQ-    Distribution.Solver.Modular.Package-    Distribution.Solver.Modular.Preference-    Distribution.Solver.Modular.RetryLog-    Distribution.Solver.Modular.Solver-    Distribution.Solver.Modular.Tree-    Distribution.Solver.Modular.Validate-    Distribution.Solver.Modular.Var-    Distribution.Solver.Modular.Version-    Distribution.Solver.Modular.WeightedPSQ-    Distribution.Solver.Types.ComponentDeps-    Distribution.Solver.Types.ConstraintSource-    Distribution.Solver.Types.DependencyResolver-    Distribution.Solver.Types.Flag-    Distribution.Solver.Types.InstSolverPackage-    Distribution.Solver.Types.InstalledPreference-    Distribution.Solver.Types.LabeledPackageConstraint-    Distribution.Solver.Types.OptionalStanza-    Distribution.Solver.Types.PackageConstraint-    Distribution.Solver.Types.PackageFixedDeps-    Distribution.Solver.Types.PackageIndex-    Distribution.Solver.Types.PackagePath-    Distribution.Solver.Types.PackagePreferences-    Distribution.Solver.Types.PkgConfigDb-    Distribution.Solver.Types.Progress-    Distribution.Solver.Types.ResolverPackage-    Distribution.Solver.Types.Settings-    Distribution.Solver.Types.SolverId-    Distribution.Solver.Types.SolverPackage-    Distribution.Solver.Types.SourcePackage-    Distribution.Solver.Types.Variable-    Paths_cabal_install     UnitTests.Distribution.Client.ArbitraryInstances+    UnitTests.Distribution.Client.Targets     UnitTests.Distribution.Client.FileMonitor-    UnitTests.Distribution.Client.GZipUtils     UnitTests.Distribution.Client.Glob-    UnitTests.Distribution.Client.IndexUtils.Timestamp-    UnitTests.Distribution.Client.InstallPlan-    UnitTests.Distribution.Client.JobControl-    UnitTests.Distribution.Client.ProjectConfig+    UnitTests.Distribution.Client.GZipUtils     UnitTests.Distribution.Client.Sandbox     UnitTests.Distribution.Client.Sandbox.Timestamp     UnitTests.Distribution.Client.Store     UnitTests.Distribution.Client.Tar-    UnitTests.Distribution.Client.Targets     UnitTests.Distribution.Client.UserConfig-    UnitTests.Distribution.Solver.Modular.DSL-    UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils-    UnitTests.Distribution.Solver.Modular.PSQ+    UnitTests.Distribution.Client.ProjectConfig+    UnitTests.Distribution.Client.JobControl+    UnitTests.Distribution.Client.IndexUtils.Timestamp+    UnitTests.Distribution.Client.InstallPlan+    UnitTests.Distribution.Solver.Modular.Builder     UnitTests.Distribution.Solver.Modular.RetryLog     UnitTests.Distribution.Solver.Modular.Solver+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils     UnitTests.Distribution.Solver.Modular.WeightedPSQ     UnitTests.Options-   build-depends:+        array,         base,         async,-        array,         bytestring,+        cabal-install,         Cabal,         containers,         deepseq,         mtl,-        pretty,-        process,+        random,         directory,         filepath,-        hashable,-        stm,         tar,         time,-        HTTP,         zlib,-        binary,-        random,-        hackage-security,-        tasty >= 0.12,+        network-uri,+        network,+        tasty >= 1.0 && < 1.1,         tasty-hunit >= 0.10,         tasty-quickcheck,         tagged,         QuickCheck >= 2.8.2 -  if flag(old-directory)-    build-depends: old-time--  if flag(network-uri)-    build-depends: network-uri >= 2.6, network >= 2.6-  else-    build-depends: network-uri < 2.6, network < 2.6--  if impl(ghc < 7.6)-    build-depends: ghc-prim >= 0.2 && < 0.3--  if os(windows)-    build-depends: Win32-  else-    build-depends: unix--  ghc-options: -fno-ignore-asserts--  if !(arch(arm) && impl(ghc < 7.6))-    ghc-options: -threaded--  if flag(debug-expensive-assertions)-    cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS--  if flag(debug-conflict-sets)-    cpp-options: -DDEBUG_CONFLICT_SETS-    build-depends: base >= 4.8+  ghc-options: -threaded -  if flag(debug-tracetree)-      cpp-options: -DDEBUG_TRACETREE-      build-depends: tracetree >= 0.1 && < 0.2+  if !flag(lib)+    buildable: False    default-language: Haskell2010 @@ -614,75 +692,9 @@ Test-Suite memory-usage-tests   type: exitcode-stdio-1.0   main-is: MemoryUsageTests.hs-  hs-source-dirs: tests, .+  hs-source-dirs: tests   ghc-options: -Wall -fwarn-tabs "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests   other-modules:-    Distribution.Client.Compat.Prelude-    Distribution.Client.Dependency-    Distribution.Client.Dependency.Types-    Distribution.Client.FetchUtils-    Distribution.Client.GZipUtils-    Distribution.Client.GlobalFlags-    Distribution.Client.HttpUtils-    Distribution.Client.PackageUtils-    Distribution.Client.Sandbox.Types-    Distribution.Client.Security.DNS-    Distribution.Client.Security.HTTP-    Distribution.Client.SolverInstallPlan-    Distribution.Client.Tar-    Distribution.Client.Targets-    Distribution.Client.Types-    Distribution.Client.Utils-    Distribution.Client.Utils.Assertion-    Distribution.Client.World-    Distribution.Solver.Modular-    Distribution.Solver.Modular.Assignment-    Distribution.Solver.Modular.Builder-    Distribution.Solver.Modular.Configured-    Distribution.Solver.Modular.ConfiguredConversion-    Distribution.Solver.Modular.ConflictSet-    Distribution.Solver.Modular.Cycles-    Distribution.Solver.Modular.Dependency-    Distribution.Solver.Modular.Explore-    Distribution.Solver.Modular.Flag-    Distribution.Solver.Modular.Index-    Distribution.Solver.Modular.IndexConversion-    Distribution.Solver.Modular.LabeledGraph-    Distribution.Solver.Modular.Linking-    Distribution.Solver.Modular.Log-    Distribution.Solver.Modular.Message-    Distribution.Solver.Modular.PSQ-    Distribution.Solver.Modular.Package-    Distribution.Solver.Modular.Preference-    Distribution.Solver.Modular.RetryLog-    Distribution.Solver.Modular.Solver-    Distribution.Solver.Modular.Tree-    Distribution.Solver.Modular.Validate-    Distribution.Solver.Modular.Var-    Distribution.Solver.Modular.Version-    Distribution.Solver.Modular.WeightedPSQ-    Distribution.Solver.Types.ComponentDeps-    Distribution.Solver.Types.ConstraintSource-    Distribution.Solver.Types.DependencyResolver-    Distribution.Solver.Types.Flag-    Distribution.Solver.Types.InstSolverPackage-    Distribution.Solver.Types.InstalledPreference-    Distribution.Solver.Types.LabeledPackageConstraint-    Distribution.Solver.Types.OptionalStanza-    Distribution.Solver.Types.PackageConstraint-    Distribution.Solver.Types.PackageFixedDeps-    Distribution.Solver.Types.PackageIndex-    Distribution.Solver.Types.PackagePath-    Distribution.Solver.Types.PackagePreferences-    Distribution.Solver.Types.PkgConfigDb-    Distribution.Solver.Types.Progress-    Distribution.Solver.Types.ResolverPackage-    Distribution.Solver.Types.Settings-    Distribution.Solver.Types.SolverId-    Distribution.Solver.Types.SolverPackage-    Distribution.Solver.Types.SourcePackage-    Distribution.Solver.Types.Variable-    Paths_cabal_install     UnitTests.Distribution.Solver.Modular.DSL     UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils     UnitTests.Distribution.Solver.Modular.MemoryUsage@@ -690,60 +702,18 @@   build-depends:         base,         async,-        array,-        bytestring,         Cabal,+        cabal-install,         containers,         deepseq,-        mtl,-        pretty,-        process,-        directory,-        filepath,-        hashable,-        stm,-        tar,-        time,-        HTTP,-        zlib,-        binary,-        random,-        hackage-security,         tagged,-        tasty >= 0.12,+        tasty >= 1.0 && < 1.1,         tasty-hunit >= 0.10 -  if flag(old-directory)-    build-depends: old-time--  if flag(network-uri)-    build-depends: network-uri >= 2.6, network >= 2.6-  else-    build-depends: network-uri < 2.6, network < 2.6--  if impl(ghc < 7.6)-    build-depends: ghc-prim >= 0.2 && < 0.3--  if os(windows)-    build-depends: Win32-  else-    build-depends: unix--  ghc-options: -fno-ignore-asserts--  if !(arch(arm) && impl(ghc < 7.6))-    ghc-options: -threaded--  if flag(debug-expensive-assertions)-    cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS--  if flag(debug-conflict-sets)-    cpp-options: -DDEBUG_CONFLICT_SETS-    build-depends: base >= 4.8+  ghc-options: -threaded -  if flag(debug-tracetree)-      cpp-options: -DDEBUG_TRACETREE-      build-depends: tracetree >= 0.1 && < 0.2+  if !flag(lib)+    buildable: False    default-language: Haskell2010 @@ -751,137 +721,31 @@ Test-Suite solver-quickcheck   type: exitcode-stdio-1.0   main-is: SolverQuickCheck.hs-  hs-source-dirs: tests, .-  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is SolverQuickCheck+  hs-source-dirs: tests+  ghc-options: -Wall -fwarn-tabs -main-is SolverQuickCheck   other-modules:-    Distribution.Client.BuildReports.Types-    Distribution.Client.Compat.Prelude-    Distribution.Client.Dependency-    Distribution.Client.Dependency.Types-    Distribution.Client.FetchUtils-    Distribution.Client.GZipUtils-    Distribution.Client.GlobalFlags-    Distribution.Client.HttpUtils-    Distribution.Client.IndexUtils.Timestamp-    Distribution.Client.Init.Types-    Distribution.Client.PackageUtils-    Distribution.Client.Sandbox.Types-    Distribution.Client.Security.DNS-    Distribution.Client.Security.HTTP-    Distribution.Client.Setup-    Distribution.Client.SolverInstallPlan-    Distribution.Client.Tar-    Distribution.Client.Targets-    Distribution.Client.Types-    Distribution.Client.Utils-    Distribution.Client.Utils.Assertion-    Distribution.Client.World-    Distribution.Solver.Modular-    Distribution.Solver.Modular.Assignment-    Distribution.Solver.Modular.Builder-    Distribution.Solver.Modular.Configured-    Distribution.Solver.Modular.ConfiguredConversion-    Distribution.Solver.Modular.ConflictSet-    Distribution.Solver.Modular.Cycles-    Distribution.Solver.Modular.Dependency-    Distribution.Solver.Modular.Explore-    Distribution.Solver.Modular.Flag-    Distribution.Solver.Modular.Index-    Distribution.Solver.Modular.IndexConversion-    Distribution.Solver.Modular.LabeledGraph-    Distribution.Solver.Modular.Linking-    Distribution.Solver.Modular.Log-    Distribution.Solver.Modular.Message-    Distribution.Solver.Modular.PSQ-    Distribution.Solver.Modular.Package-    Distribution.Solver.Modular.Preference-    Distribution.Solver.Modular.RetryLog-    Distribution.Solver.Modular.Solver-    Distribution.Solver.Modular.Tree-    Distribution.Solver.Modular.Validate-    Distribution.Solver.Modular.Var-    Distribution.Solver.Modular.Version-    Distribution.Solver.Modular.WeightedPSQ-    Distribution.Solver.Types.ComponentDeps-    Distribution.Solver.Types.ConstraintSource-    Distribution.Solver.Types.DependencyResolver-    Distribution.Solver.Types.Flag-    Distribution.Solver.Types.InstSolverPackage-    Distribution.Solver.Types.InstalledPreference-    Distribution.Solver.Types.LabeledPackageConstraint-    Distribution.Solver.Types.OptionalStanza-    Distribution.Solver.Types.PackageConstraint-    Distribution.Solver.Types.PackageFixedDeps-    Distribution.Solver.Types.PackageIndex-    Distribution.Solver.Types.PackagePath-    Distribution.Solver.Types.PackagePreferences-    Distribution.Solver.Types.PkgConfigDb-    Distribution.Solver.Types.Progress-    Distribution.Solver.Types.ResolverPackage-    Distribution.Solver.Types.Settings-    Distribution.Solver.Types.SolverId-    Distribution.Solver.Types.SolverPackage-    Distribution.Solver.Types.SourcePackage-    Distribution.Solver.Types.Variable-    Paths_cabal_install     UnitTests.Distribution.Solver.Modular.DSL     UnitTests.Distribution.Solver.Modular.QuickCheck+    UnitTests.Distribution.Solver.Modular.QuickCheck.Utils   build-depends:         base,         async,-        array,-        bytestring,         Cabal,+        cabal-install,         containers,         deepseq >= 1.2,-        mtl,-        pretty,-        process,-        directory,-        filepath,         hashable,-        stm,-        tar,-        time,-        HTTP,-        zlib,-        binary,         random,-        hackage-security,-        tasty >= 0.12,+        tagged,+        tasty >= 1.0 && <1.1,         tasty-quickcheck,         QuickCheck >= 2.8.2,-        pretty-show--  if flag(old-directory)-    build-depends: old-time--  if flag(network-uri)-    build-depends: network-uri >= 2.6, network >= 2.6-  else-    build-depends: network-uri < 2.6, network < 2.6--  if impl(ghc < 7.6)-    build-depends: ghc-prim >= 0.2 && < 0.3--  if os(windows)-    build-depends: Win32-  else-    build-depends: unix--  if !(arch(arm) && impl(ghc < 7.6))-    ghc-options: -threaded--  if flag(debug-expensive-assertions)-    cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS+        pretty-show >= 1.6.15 -  if flag(debug-conflict-sets)-    cpp-options: -DDEBUG_CONFLICT_SETS-    build-depends: base >= 4.8+  ghc-options: -threaded -  if flag(debug-tracetree)-      cpp-options: -DDEBUG_TRACETREE-      build-depends: tracetree >= 0.1 && < 0.2+  if !flag(lib)+    buildable: False    default-language: Haskell2010 @@ -890,167 +754,30 @@ test-suite integration-tests2   type: exitcode-stdio-1.0   main-is: IntegrationTests2.hs-  hs-source-dirs: tests, .-  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is IntegrationTests2+  hs-source-dirs: tests+  ghc-options: -Wall -fwarn-tabs -main-is IntegrationTests2   other-modules:-    Distribution.Client.BuildReports.Types-    Distribution.Client.CmdBench-    Distribution.Client.CmdBuild-    Distribution.Client.CmdErrorMessages-    Distribution.Client.CmdHaddock-    Distribution.Client.CmdRepl-    Distribution.Client.CmdRun-    Distribution.Client.CmdTest-    Distribution.Client.Compat.ExecutablePath-    Distribution.Client.Compat.FileLock-    Distribution.Client.Compat.Prelude-    Distribution.Client.Compat.Semaphore-    Distribution.Client.Config-    Distribution.Client.Dependency-    Distribution.Client.Dependency.Types-    Distribution.Client.DistDirLayout-    Distribution.Client.FetchUtils-    Distribution.Client.FileMonitor-    Distribution.Client.GZipUtils-    Distribution.Client.Glob-    Distribution.Client.GlobalFlags-    Distribution.Client.HttpUtils-    Distribution.Client.IndexUtils-    Distribution.Client.IndexUtils.Timestamp-    Distribution.Client.Init.Types-    Distribution.Client.InstallPlan-    Distribution.Client.JobControl-    Distribution.Client.PackageHash-    Distribution.Client.PackageUtils-    Distribution.Client.ParseUtils-    Distribution.Client.ProjectBuilding-    Distribution.Client.ProjectBuilding.Types-    Distribution.Client.ProjectConfig-    Distribution.Client.ProjectConfig.Legacy-    Distribution.Client.ProjectConfig.Types-    Distribution.Client.ProjectOrchestration-    Distribution.Client.ProjectPlanOutput-    Distribution.Client.ProjectPlanning-    Distribution.Client.ProjectPlanning.Types-    Distribution.Client.RebuildMonad-    Distribution.Client.Sandbox.Types-    Distribution.Client.Security.DNS-    Distribution.Client.Security.HTTP-    Distribution.Client.Setup-    Distribution.Client.SetupWrapper-    Distribution.Client.SolverInstallPlan-    Distribution.Client.SourceFiles-    Distribution.Client.SrcDist-    Distribution.Client.Store-    Distribution.Client.Tar-    Distribution.Client.TargetSelector-    Distribution.Client.Targets-    Distribution.Client.Types-    Distribution.Client.Utils-    Distribution.Client.Utils.Assertion-    Distribution.Client.Utils.Json-    Distribution.Client.World-    Distribution.Solver.Modular-    Distribution.Solver.Modular.Assignment-    Distribution.Solver.Modular.Builder-    Distribution.Solver.Modular.Configured-    Distribution.Solver.Modular.ConfiguredConversion-    Distribution.Solver.Modular.ConflictSet-    Distribution.Solver.Modular.Cycles-    Distribution.Solver.Modular.Dependency-    Distribution.Solver.Modular.Explore-    Distribution.Solver.Modular.Flag-    Distribution.Solver.Modular.Index-    Distribution.Solver.Modular.IndexConversion-    Distribution.Solver.Modular.LabeledGraph-    Distribution.Solver.Modular.Linking-    Distribution.Solver.Modular.Log-    Distribution.Solver.Modular.Message-    Distribution.Solver.Modular.PSQ-    Distribution.Solver.Modular.Package-    Distribution.Solver.Modular.Preference-    Distribution.Solver.Modular.RetryLog-    Distribution.Solver.Modular.Solver-    Distribution.Solver.Modular.Tree-    Distribution.Solver.Modular.Validate-    Distribution.Solver.Modular.Var-    Distribution.Solver.Modular.Version-    Distribution.Solver.Modular.WeightedPSQ-    Distribution.Solver.Types.ComponentDeps-    Distribution.Solver.Types.ConstraintSource-    Distribution.Solver.Types.DependencyResolver-    Distribution.Solver.Types.Flag-    Distribution.Solver.Types.InstSolverPackage-    Distribution.Solver.Types.InstalledPreference-    Distribution.Solver.Types.LabeledPackageConstraint-    Distribution.Solver.Types.OptionalStanza-    Distribution.Solver.Types.PackageConstraint-    Distribution.Solver.Types.PackageFixedDeps-    Distribution.Solver.Types.PackageIndex-    Distribution.Solver.Types.PackagePath-    Distribution.Solver.Types.PackagePreferences-    Distribution.Solver.Types.PkgConfigDb-    Distribution.Solver.Types.Progress-    Distribution.Solver.Types.ResolverPackage-    Distribution.Solver.Types.Settings-    Distribution.Solver.Types.SolverId-    Distribution.Solver.Types.SolverPackage-    Distribution.Solver.Types.SourcePackage-    Distribution.Solver.Types.Variable-    Paths_cabal_install   build-depends:-        async,-        array,         base,-        base16-bytestring,-        binary,-        bytestring,         Cabal,+        cabal-install,         containers,-        cryptohash-sha256,         deepseq,         directory,         edit-distance,         filepath,-        hackage-security,-        hashable,-        HTTP,-        mtl,-        network,-        network-uri,-        pretty,-        process,-        random,-        stm,-        tar,-        time,-        zlib,-        tasty >= 0.12,+        tasty >= 1.0 && < 1.1,         tasty-hunit >= 0.10,         tagged -  if flag(old-bytestring)-    build-depends: bytestring-builder--  if flag(old-directory)-    build-depends: old-time--  if impl(ghc < 7.6)-    build-depends: ghc-prim >= 0.2 && < 0.3--  if os(windows)-    build-depends: Win32-  else-    build-depends: unix+  if !flag(lib)+    buildable: False -  if arch(arm)-    cc-options:  -DCABAL_NO_THREADED-  else-    ghc-options: -threaded+  ghc-options: -threaded   default-language: Haskell2010  custom-setup-  setup-depends: Cabal >= 2.0,+  setup-depends: Cabal >= 2.2,                  base,                  process   >= 1.1.0.1  && < 1.7,-                 filepath   >= 1.3      && < 1.5+                 filepath  >= 1.3      && < 1.5

changelog view

@@ -1,5 +1,75 @@ -*-change-log-*- +2.2.0.0 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> March 2018+        * '--with-PROG' and '--PROG-options' are applied to all packages+	and not local packages only (#5019).+	* Completed the 'new-update' command (#4809), which respects nix-style+	cabal.project(.local) files and allows to update from+	multiple repositories when using overlays.+	* Completed the 'new-run' command (#4477). The functionality is the+	same of the old 'run' command but using nix-style builds.+	Additionally, it can run executables across packages in a project.+	Tests and benchmarks are also treated as executables, providing a+	quick way to pass them arguments.+	* Completed the 'new-bench' command (#3638). Same as above.+	* Completed the 'new-exec' command (#3638). Same as above.+	* Added a preliminary 'new-install' command (#4558, nonlocal exes+	part) which allows to quickly install executables from Hackage.+	* Set symlink-bindir (used by new-install) to .cabal/bin by default on+	.cabal/config initialization (#5188).+	* 'cabal update' now supports '--index-state' which can be used to+	roll back the index to an earlier state.+	* '--allow-{newer,older}' syntax has been enhanced. Dependency+	relaxation can be now limited to a specific release of a package,+	plus there's a new syntax for relaxing only caret-style (i.e. '^>=')+	dependencies (#4575, #4669).+	* New config file field: 'cxx-options' to specify which options to be+	passed to the compiler when compiling C++ sources specified by the+	'cxx-sources' field. (#3700)+	* New config file field: 'cxx-sources' to specify C++ files to be+	compiled separately from C source files. Useful in conjunction with the+	'cxx-options' flag to pass different compiler options to C and C+++	source files. (#3700)+	* Use [lfxtb] letters to differentiate component kind instead of+	opaque "c" in dist-dir layout.+	* 'cabal configure' now supports '--enable-static', which can be+	used to build static libaries with GHC via GHC's `-staticlib`+	flag.+	* 'cabal user-config now supports '--augment' which can append+	additional lines to a new or updated cabal config file.+	* Added support for '--enable-tests' and '--enable-benchmarks' to+	'cabal fetch' (#4948).+	* Misspelled package-names on CLI will no longer be silently+	case-corrected (#4778).+	* 'cabal new-configure' now backs up the old 'cabal.project.local'+	file if it exists (#4460).+	* On macOS, `new-build` will now place dynamic libraries into+	`store/lib` and aggressively shorten their names in an effort to+	stay within the load command size limits of macOSs mach-o linker.+	* 'new-build' now checks for the existence of executables for+	build-tools and build-tool-depends dependencies in the solver+	(#4884).+	* Fixed a spurious warning telling the user to run 'cabal update'+	when it wasn't necessary (#4444).+	* Packages installed in sandboxes via 'add-source' now have+	their timestamps updated correctly and so will not be reinstalled+	unncecessarily if the main install command fails (#1375).+	* Add Windows device path support for copyFile, renameFile. Allows cabal+	new-build to use temporary store path of up to 32k length+	(#3972, #4914, #4515).+	* When a flag value is specified multiple times on the command+	line, the last one is now preferred, so e.g. '-f+dev -f-dev' is+	now equivalent to '-f-dev' (#4452).+	* Removed support for building cabal-install with GHC < 7.10 (#4870).+	* New 'package *' section in 'cabal.project' files that applies+	options to all packages, not just those local to the project.+	* 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 when compiling a custom `Setup.hs` script using+	`new-build` (#5164).+ 2.0.0.1 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> December 2017 	* Support for GHC's numeric -g debug levels (#4673). 	* Demoted 'scope' field version check to a warning (#4714).@@ -155,7 +225,8 @@  1.22.7.0 Ryan Thomas <ryan@ryant.org> December 2015 	* Remove GZipUtils tests-	* maybeDecompress: bail on all errors at the beginning of the stream with zlib < 0.6+	* maybeDecompress: bail on all errors at the beginning of the+	stream with zlib < 0.6 	* Correct maybeDecompress  1.22.6.0 Ryan Thomas <ryan@ryant.org> June 2015@@ -167,10 +238,12 @@ 1.22.4.0 Ryan Thomas <ryan@ryant.org> May 2015 	* Force cabal upload to always use digest auth and never basic auth. 	* Add dependency-graph information to `printPlan` output-	* bootstrap.sh: fixes linker matching to avoid cases where tested linker names appear unexpectedly in compiler output (fixes #2542)+	* bootstrap.sh: fixes linker matching to avoid cases where tested+	linker names appear unexpectedly in compiler output (fixes #2542)  1.22.3.0 Ryan Thomas <ryan@ryant.org> April 2015-	* Fix bash completion for sandbox subcommands - Fixes #2513 (Mikhail Glushenkov)+	* Fix bash completion for sandbox subcommands - Fixes #2513+	(Mikhail Glushenkov) 	* filterConfigureFlags: filter more flags (Mikhail Glushenkov)  1.22.2.0 Ryan Thomas <ryan@ryant.org> March 2015

+ main/Main.hs view

@@ -0,0 +1,1229 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Entry point to the default cabal-install front-end.+-----------------------------------------------------------------------------++module Main (main) where++import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand, withRepoContext+         , ConfigFlags(..)+         , ConfigExFlags(..), defaultConfigExFlags, configureExCommand+         , reconfigureCommand+         , configCompilerAux', configPackageDB'+         , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+         , buildCommand, replCommand, testCommand, benchmarkCommand+         , InstallFlags(..), defaultInstallFlags+         , installCommand, upgradeCommand, uninstallCommand+         , FetchFlags(..), fetchCommand+         , FreezeFlags(..), freezeCommand+         , genBoundsCommand+         , OutdatedFlags(..), outdatedCommand+         , GetFlags(..), getCommand, unpackCommand+         , checkCommand+         , formatCommand+         , UpdateFlags(..), updateCommand+         , ListFlags(..), listCommand+         , InfoFlags(..), infoCommand+         , UploadFlags(..), uploadCommand+         , ReportFlags(..), reportCommand+         , runCommand+         , InitFlags(initVerbosity), initCommand+         , SDistFlags(..), SDistExFlags(..), sdistCommand+         , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand+         , ActAsSetupFlags(..), actAsSetupCommand+         , SandboxFlags(..), sandboxCommand+         , ExecFlags(..), execCommand+         , UserConfigFlags(..), userConfigCommand+         , reportCommand+         , manpageCommand+         )+import Distribution.Simple.Setup+         ( HaddockTarget(..)+         , DoctestFlags(..), doctestCommand+         , HaddockFlags(..), haddockCommand, defaultHaddockFlags+         , HscolourFlags(..), hscolourCommand+         , ReplFlags(..)+         , CopyFlags(..), copyCommand+         , RegisterFlags(..), registerCommand+         , CleanFlags(..), cleanCommand+         , TestFlags(..), BenchmarkFlags(..)+         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag+         , configAbsolutePaths+         )++import Prelude ()+import Distribution.Solver.Compat.Prelude hiding (get)++import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Config+         ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff+         , userConfigUpdate, createDefaultConfigFile, getConfigFilePath )+import Distribution.Client.Targets+         ( readUserTargets )+import qualified Distribution.Client.List as List+         ( list, info )+++import qualified Distribution.Client.CmdConfigure as CmdConfigure+import qualified Distribution.Client.CmdUpdate    as CmdUpdate+import qualified Distribution.Client.CmdBuild     as CmdBuild+import qualified Distribution.Client.CmdRepl      as CmdRepl+import qualified Distribution.Client.CmdFreeze    as CmdFreeze+import qualified Distribution.Client.CmdHaddock   as CmdHaddock+import qualified Distribution.Client.CmdInstall   as CmdInstall+import qualified Distribution.Client.CmdRun       as CmdRun+import qualified Distribution.Client.CmdTest      as CmdTest+import qualified Distribution.Client.CmdBench     as CmdBench+import qualified Distribution.Client.CmdExec      as CmdExec++import Distribution.Client.Install            (install)+import Distribution.Client.Configure          (configure, writeConfigFlags)+import Distribution.Client.Update             (update)+import Distribution.Client.Exec               (exec)+import Distribution.Client.Fetch              (fetch)+import Distribution.Client.Freeze             (freeze)+import Distribution.Client.GenBounds          (genBounds)+import Distribution.Client.Outdated           (outdated)+import Distribution.Client.Check as Check     (check)+--import Distribution.Client.Clean            (clean)+import qualified Distribution.Client.Upload as Upload+import Distribution.Client.Run                (run, splitRunArgs)+import Distribution.Client.SrcDist            (sdist)+import Distribution.Client.Get                (get)+import Distribution.Client.Reconfigure        (Check(..), reconfigure)+import Distribution.Client.Nix                (nixInstantiate+                                              ,nixShell+                                              ,nixShellIfSandboxed)+import Distribution.Client.Sandbox            (sandboxInit+                                              ,sandboxAddSource+                                              ,sandboxDelete+                                              ,sandboxDeleteSource+                                              ,sandboxListSources+                                              ,sandboxHcPkg+                                              ,dumpPackageEnvironment++                                              ,loadConfigOrSandboxConfig+                                              ,findSavedDistPref+                                              ,initPackageDBIfNeeded+                                              ,maybeWithSandboxDirOnSearchPath+                                              ,maybeWithSandboxPackageInfo+                                              ,tryGetIndexFilePath+                                              ,sandboxBuildDir+                                              ,updateSandboxConfigFileFlag+                                              ,updateInstallDirs++                                              ,getPersistOrConfigCompiler)+import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB)+import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord)+import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox)+import Distribution.Client.Tar                (createTarGzFile)+import Distribution.Client.Types              (Password (..))+import Distribution.Client.Init               (initCabal)+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)+import Distribution.PackageDescription+         ( BuildType(..), Executable(..), buildable )+import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )++import Distribution.PackageDescription.PrettyPrint+         ( writeGenericPackageDescription )+import qualified Distribution.Simple as Simple+import qualified Distribution.Make as Make+import qualified Distribution.Types.UnqualComponentName as Make+import Distribution.Simple.Build+         ( startInterpreter )+import Distribution.Simple.Command+         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)+         , CommandType(..), commandsRun, commandAddAction, hiddenCommand+         , commandFromSpec, commandShowOptions )+import Distribution.Simple.Compiler (Compiler(..), PackageDBStack)+import Distribution.Simple.Configure+         ( configCompilerAuxEx, ConfigStateFileError(..)+         , getPersistBuildConfig, interpretPackageDbFlags+         , tryGetPersistBuildConfig )+import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Program (defaultProgramDb+                                   ,configureAllKnownPrograms+                                   ,simpleProgramInvocation+                                   ,getProgramInvocationOutput)+import Distribution.Simple.Program.Db (reconfigurePrograms)+import qualified Distribution.Simple.Setup as Cabal+import Distribution.Simple.Utils+         ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler+         , findPackageDesc, tryFindPackageDesc )+import Distribution.Text+         ( display )+import Distribution.Verbosity as Verbosity+         ( Verbosity, normal )+import Distribution.Version+         ( Version, mkVersion, orLaterVersion )+import qualified Paths_cabal_install (version)++import System.Environment       (getArgs, getProgName)+import System.Exit              (exitFailure, exitSuccess)+import System.FilePath          ( dropExtension, splitExtension+                                , takeExtension, (</>), (<.>))+import System.IO                ( BufferMode(LineBuffering), hSetBuffering+#ifdef mingw32_HOST_OS+                                , stderr+#endif+                                , stdout )+import System.Directory         (doesFileExist, getCurrentDirectory)+import Data.Monoid              (Any(..))+import Control.Exception        (SomeException(..), try)+import Control.Monad            (mapM_)++#ifdef MONOLITHIC+import qualified UnitTests+import qualified MemoryUsageTests+import qualified SolverQuickCheck+import qualified IntegrationTests2+import qualified System.Environment as Monolithic+#endif++-- | Entry point+--+main :: IO ()+#ifdef MONOLITHIC+main = do+    mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE"+    case mb_exec of+        Just "UnitTests"         -> UnitTests.main+        Just "MemoryUsageTests"  -> MemoryUsageTests.main+        Just "SolverQuickCheck"  -> SolverQuickCheck.main+        Just "IntegrationTests2" -> IntegrationTests2.main+        Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE"+        Nothing -> main'+#else+main = main'+#endif++main' :: IO ()+main' = do+  -- 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+  relaxEncodingErrors stdout+  relaxEncodingErrors stderr+#endif+  getArgs >>= mainWorker++mainWorker :: [String] -> IO ()+mainWorker args = topHandler $+  case commandsRun (globalCommand commands) commands args of+    CommandHelp   help                 -> printGlobalHelp help+    CommandList   opts                 -> printOptionsList opts+    CommandErrors errs                 -> printErrors errs+    CommandReadyToGo (globalFlags, commandParse)  ->+      case commandParse of+        _ | fromFlagOrDefault False (globalVersion globalFlags)+            -> printVersion+          | fromFlagOrDefault False (globalNumericVersion globalFlags)+            -> printNumericVersion+        CommandHelp     help           -> printCommandHelp help+        CommandList     opts           -> printOptionsList opts+        CommandErrors   errs           -> printErrors errs+        CommandReadyToGo action        -> do+          globalFlags' <- updateSandboxConfigFileFlag globalFlags+          action globalFlags'++  where+    printCommandHelp help = do+      pname <- getProgName+      putStr (help pname)+    printGlobalHelp help = do+      pname <- getProgName+      configFile <- defaultConfigFile+      putStr (help pname)+      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"+            ++ "  " ++ configFile ++ "\n"+      exists <- doesFileExist configFile+      unless exists $+          putStrLn $ "This file will be generated with sensible "+                  ++ "defaults if you run 'cabal update'."+    printOptionsList = putStr . unlines+    printErrors errs = dieNoVerbosity $ intercalate "\n" errs+    printNumericVersion = putStrLn $ display Paths_cabal_install.version+    printVersion        = putStrLn $ "cabal-install version "+                                  ++ display Paths_cabal_install.version+                                  ++ "\ncompiled using version "+                                  ++ display cabalVersion+                                  ++ " of the Cabal library "++    commands = map commandFromSpec commandSpecs+    commandSpecs =+      [ regularCmd installCommand installAction+      , regularCmd updateCommand updateAction+      , regularCmd listCommand listAction+      , regularCmd infoCommand infoAction+      , regularCmd fetchCommand fetchAction+      , regularCmd freezeCommand freezeAction+      , regularCmd getCommand getAction+      , hiddenCmd  unpackCommand unpackAction+      , regularCmd checkCommand checkAction+      , regularCmd sdistCommand sdistAction+      , regularCmd uploadCommand uploadAction+      , regularCmd reportCommand reportAction+      , regularCmd runCommand runAction+      , regularCmd initCommand initAction+      , regularCmd configureExCommand configureAction+      , regularCmd reconfigureCommand reconfigureAction+      , regularCmd buildCommand buildAction+      , regularCmd replCommand replAction+      , regularCmd sandboxCommand sandboxAction+      , regularCmd doctestCommand doctestAction+      , regularCmd haddockCommand haddockAction+      , regularCmd execCommand execAction+      , regularCmd userConfigCommand userConfigAction+      , regularCmd cleanCommand cleanAction+      , regularCmd genBoundsCommand genBoundsAction+      , regularCmd outdatedCommand outdatedAction+      , wrapperCmd copyCommand copyVerbosity copyDistPref+      , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref+      , wrapperCmd registerCommand regVerbosity regDistPref+      , regularCmd testCommand testAction+      , regularCmd benchmarkCommand benchmarkAction+      , hiddenCmd  uninstallCommand uninstallAction+      , hiddenCmd  formatCommand formatAction+      , hiddenCmd  upgradeCommand upgradeAction+      , hiddenCmd  win32SelfUpgradeCommand win32SelfUpgradeAction+      , hiddenCmd  actAsSetupCommand actAsSetupAction+      , hiddenCmd  manpageCommand (manpageAction commandSpecs)++      , regularCmd  CmdConfigure.configureCommand CmdConfigure.configureAction+      , regularCmd  CmdUpdate.updateCommand       CmdUpdate.updateAction+      , regularCmd  CmdBuild.buildCommand         CmdBuild.buildAction+      , regularCmd  CmdRepl.replCommand           CmdRepl.replAction+      , regularCmd  CmdFreeze.freezeCommand       CmdFreeze.freezeAction+      , regularCmd  CmdHaddock.haddockCommand     CmdHaddock.haddockAction+      , regularCmd  CmdInstall.installCommand     CmdInstall.installAction+      , regularCmd  CmdRun.runCommand             CmdRun.runAction+      , regularCmd  CmdTest.testCommand           CmdTest.testAction+      , regularCmd  CmdBench.benchCommand         CmdBench.benchAction+      , regularCmd  CmdExec.execCommand           CmdExec.execAction+      ]++type Action = GlobalFlags -> IO ()++regularCmd :: CommandUI flags -> (flags -> [String] -> action)+           -> CommandSpec action+regularCmd ui action =+  CommandSpec ui ((flip commandAddAction) action) NormalCommand++hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)+          -> CommandSpec action+hiddenCmd ui action =+  CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))+  HiddenCommand++wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)+           -> (flags -> Flag String) -> CommandSpec Action+wrapperCmd ui verbosity distPref =+  CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand++wrapperAction :: Monoid flags+              => CommandUI flags+              -> (flags -> Flag Verbosity)+              -> (flags -> Flag String)+              -> Command Action+wrapperAction command verbosityFlag distPrefFlag =+  commandAddAction command+    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do+    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)+    load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+    let config = either (\(SomeException _) -> mempty) snd load+    distPref <- findSavedDistPref config (distPrefFlag flags)+    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }+    setupWrapper verbosity setupScriptOptions Nothing+                 command (const flags) extraArgs++configureAction :: (ConfigFlags, ConfigExFlags)+                -> [String] -> Action+configureAction (configFlags, configExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+                          <$> loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (configDistPref configFlags)+  nixInstantiate verbosity distPref True globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let configFlags'   = savedConfigureFlags   config `mappend` configFlags+        configExFlags' = savedConfigureExFlags config `mappend` configExFlags+        globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAuxEx configFlags'++    -- If we're working inside a sandbox and the user has set the -w option, we+    -- may need to create a sandbox-local package DB for this compiler and add a+    -- timestamp record for this compiler to the timestamp file.+    let configFlags''  = case useSandbox of+          NoSandbox               -> configFlags'+          (UseSandbox sandboxDir) -> setPackageDB sandboxDir+                                    comp platform configFlags'++    writeConfigFlags verbosity distPref (configFlags'', configExFlags')++    -- What package database(s) to use+    let packageDBs :: PackageDBStack+        packageDBs+          = interpretPackageDbFlags+            (fromFlag (configUserInstall configFlags''))+            (configPackageDBs configFlags'')++    whenUsingSandbox useSandbox $ \sandboxDir -> do+      initPackageDBIfNeeded verbosity configFlags'' comp progdb+      -- NOTE: We do not write the new sandbox package DB location to+      -- 'cabal.sandbox.config' here because 'configure -w' must not affect+      -- subsequent 'install' (for UI compatibility with non-sandboxed mode).++      indexFile     <- tryGetIndexFilePath verbosity config+      maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+        (compilerId comp) platform++    maybeWithSandboxDirOnSearchPath useSandbox $+      withRepoContext verbosity globalFlags' $ \repoContext ->+        configure verbosity packageDBs repoContext+                  comp platform progdb configFlags'' configExFlags' extraArgs++reconfigureAction :: (ConfigFlags, ConfigExFlags)+                  -> [String] -> Action+reconfigureAction flags@(configFlags, _) _ globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+                          <$> loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (configDistPref configFlags)+  let checkFlags = Check $ \_ saved -> do+        let flags' = saved <> flags+        unless (saved == flags') $ info verbosity message+        pure (Any True, flags')+        where+          -- This message is correct, but not very specific: it will list all+          -- of the new flags, even if some have not actually changed. The+          -- *minimal* set of changes is more difficult to determine.+          message =+            "flags changed: "+            ++ unwords (commandShowOptions configureExCommand flags)+  nixInstantiate verbosity distPref True globalFlags config+  _ <-+    reconfigure configureAction+    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag+    checkFlags [] globalFlags config+  pure ()++buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action+buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)+      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (buildDistPref buildFlags)+  -- Calls 'configureAction' to do the real work, so nothing special has to be+  -- done to support sandboxes.+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    mempty [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config' distPref buildFlags extraArgs+++-- | Actually do the work of building the package. This is separate from+-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke+-- 'reconfigure' twice.+build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()+build verbosity config distPref buildFlags extraArgs =+  setupWrapper verbosity setupOptions Nothing+               (Cabal.buildCommand progDb) mkBuildFlags extraArgs+  where+    progDb       = defaultProgramDb+    setupOptions = defaultSetupScriptOptions { useDistPref = distPref }++    mkBuildFlags version = filterBuildFlags version config buildFlags'+    buildFlags' = buildFlags+      { buildVerbosity = toFlag verbosity+      , buildDistPref  = toFlag distPref+      }++-- | Make sure that we don't pass new flags to setup scripts compiled against+-- old versions of Cabal.+filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags+filterBuildFlags version config buildFlags+  | version >= mkVersion [1,19,1] = buildFlags_latest+  -- Cabal < 1.19.1 doesn't support 'build -j'.+  | otherwise                      = buildFlags_pre_1_19_1+  where+    buildFlags_pre_1_19_1 = buildFlags {+      buildNumJobs = NoFlag+      }+    buildFlags_latest     = buildFlags {+      -- Take the 'jobs' setting '~/.cabal/config' into account.+      buildNumJobs = Flag . Just . determineNumJobs $+                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)+      }+    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config+    numJobsCmdLineFlag = buildNumJobs buildFlags+++replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action+replAction (replFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (replVerbosity replFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (replDistPref replFlags)+  cwd     <- getCurrentDirectory+  pkgDesc <- findPackageDesc cwd+  let+    -- There is a .cabal file in the current directory: start a REPL and load+    -- the project's modules.+    onPkgDesc = do+      let noAddSource = case replReload replFlags of+            Flag True -> SkipAddSourceDepsCheck+            _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck+                        (buildOnly buildExFlags)++      -- Calls 'configureAction' to do the real work, so nothing special has to+      -- be done to support sandboxes.+      _ <-+        reconfigure configureAction+        verbosity distPref useSandbox noAddSource NoFlag+        mempty [] globalFlags config+      let progDb = defaultProgramDb+          setupOptions = defaultSetupScriptOptions+            { useCabalVersion = orLaterVersion $ mkVersion [1,18,0]+            , useDistPref     = distPref+            }+          replFlags'   = replFlags+            { replVerbosity = toFlag verbosity+            , replDistPref  = toFlag distPref+            }++      nixShell verbosity distPref globalFlags config $ do+        maybeWithSandboxDirOnSearchPath useSandbox $+          setupWrapper verbosity setupOptions Nothing+          (Cabal.replCommand progDb) (const replFlags') extraArgs++    -- No .cabal file in the current directory: just start the REPL (possibly+    -- using the sandbox package DB).+    onNoPkgDesc = do+      let configFlags = savedConfigureFlags config+      (comp, platform, programDb) <- configCompilerAux' configFlags+      programDb' <- reconfigurePrograms verbosity+                                        (replProgramPaths replFlags)+                                        (replProgramArgs replFlags)+                                        programDb+      nixShell verbosity distPref globalFlags config $ do+        startInterpreter verbosity programDb' comp platform+                        (configPackageDB' configFlags)++  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc++installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+              -> [String] -> Action+installAction (configFlags, _, installFlags, _) _ globalFlags+  | fromFlagOrDefault False (installOnly installFlags) = do+      let verb = fromFlagOrDefault normal (configVerbosity configFlags)+      (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags+      dist <- findSavedDistPref config (configDistPref configFlags)+      let setupOpts = defaultSetupScriptOptions { useDistPref = dist }+      nixShellIfSandboxed verb dist globalFlags config useSandbox $+        setupWrapper+        verb setupOpts Nothing+        installCommand (const mempty) []++installAction+  (configFlags, configExFlags, installFlags, haddockFlags)+  extraArgs globalFlags = do+  let verb = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+                          <$> loadConfigOrSandboxConfig verb globalFlags++  let sandboxDist =+        case useSandbox of+          NoSandbox             -> NoFlag+          UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir+  dist <- findSavedDistPref config+          (configDistPref configFlags `mappend` sandboxDist)++  nixShellIfSandboxed verb dist globalFlags config useSandbox $ do+    targets <- readUserTargets verb extraArgs++    -- 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 build && cabal install+    --+    -- performs the compilation twice unless you also pass -w to 'install'.+    -- However, this is the same behaviour that 'cabal install' has in the normal+    -- mode of operation, so we stick to it for consistency.++    let configFlags'    = maybeForceTests installFlags' $+                          savedConfigureFlags   config `mappend`+                          configFlags { configDistPref = toFlag dist }+        configExFlags'  = defaultConfigExFlags         `mappend`+                          savedConfigureExFlags config `mappend` configExFlags+        installFlags'   = defaultInstallFlags          `mappend`+                          savedInstallFlags     config `mappend` installFlags+        haddockFlags'   = defaultHaddockFlags          `mappend`+                          savedHaddockFlags     config `mappend`+                          haddockFlags { haddockDistPref = toFlag dist }+        globalFlags'    = savedGlobalFlags      config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAux' configFlags'+    -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the+    -- future.+    progdb' <- configureAllKnownPrograms verb progdb++    -- If we're working inside a sandbox and the user has set the -w option, we+    -- may need to create a sandbox-local package DB for this compiler and add a+    -- timestamp record for this compiler to the timestamp file.+    configFlags'' <- case useSandbox of+      NoSandbox               -> configAbsolutePaths $ configFlags'+      (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform+                                                      configFlags'++    whenUsingSandbox useSandbox $ \sandboxDir -> do+      initPackageDBIfNeeded verb configFlags'' comp progdb'++      indexFile     <- tryGetIndexFilePath verb config+      maybeAddCompilerTimestampRecord verb sandboxDir indexFile+        (compilerId comp) platform++    -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means+    -- that 'cabal install some-package' inside a sandbox will sometimes reinstall+    -- modified add-source deps, even if they are not among the dependencies of+    -- 'some-package'. This can also prevent packages that depend on older+    -- versions of add-source'd packages from building (see #1362).+    maybeWithSandboxPackageInfo verb configFlags'' globalFlags'+                                comp platform progdb useSandbox $ \mSandboxPkgInfo ->+                                maybeWithSandboxDirOnSearchPath useSandbox $+      withRepoContext verb globalFlags' $ \repoContext ->+        install verb+                (configPackageDB' configFlags'')+                repoContext+                comp platform progdb'+                useSandbox mSandboxPkgInfo+                globalFlags' configFlags'' configExFlags'+                installFlags' haddockFlags'+                targets++      where+        -- '--run-tests' implies '--enable-tests'.+        maybeForceTests installFlags' configFlags' =+          if fromFlagOrDefault False (installRunTests installFlags')+          then configFlags' { configTests = toFlag True }+          else configFlags'++testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags+           -> IO ()+testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (testDistPref testFlags)+  let noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck+                      (buildOnly buildExFlags)+      buildFlags'    = buildFlags+                      { buildVerbosity = testVerbosity testFlags }+      checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->+        if fromFlagOrDefault False (configTests configFlags)+          then pure (mempty, flags)+          else do+            info verbosity "reconfiguring to enable tests"+            let flags' = ( configFlags { configTests = toFlag True }+                        , configExFlags+                        )+            pure (Any True, flags')++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  _ <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    checkFlags [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+        testFlags'     = testFlags { testDistPref = toFlag distPref }++    -- The package was just configured, so the LBI must be available.+    names <- componentNamesFromLBI verbosity distPref "test suites"+              (\c -> case c of { LBI.CTest{} -> True; _ -> False })+    let extraArgs'+          | null extraArgs = case names of+            ComponentNamesUnknown -> []+            ComponentNames names' -> [ Make.unUnqualComponentName name+                                    | LBI.CTestName name <- names' ]+          | otherwise      = extraArgs++    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config distPref buildFlags' extraArgs'++    maybeWithSandboxDirOnSearchPath useSandbox $+      setupWrapper verbosity setupOptions Nothing+      Cabal.testCommand (const testFlags') extraArgs'++data ComponentNames = ComponentNamesUnknown+                    | ComponentNames [LBI.ComponentName]++-- | Return the names of all buildable components matching a given predicate.+componentNamesFromLBI :: Verbosity -> FilePath -> String+                         -> (LBI.Component -> Bool)+                         -> IO ComponentNames+componentNamesFromLBI verbosity distPref targetsDescr compPred = do+  eLBI <- tryGetPersistBuildConfig distPref+  case eLBI of+    Left err -> case err of+      -- Note: the build config could have been generated by a custom setup+      -- script built against a different Cabal version, so it's crucial that+      -- we ignore the bad version error here.+      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown+      _                               -> die' verbosity (show err)+    Right lbi -> do+      let pkgDescr = LBI.localPkgDescr lbi+          names    = map LBI.componentName+                     . filter (buildable . LBI.componentBuildInfo)+                     . filter compPred $+                     LBI.pkgComponents pkgDescr+      if null names+        then do notice verbosity $ "Package has no buildable "+                  ++ targetsDescr ++ "."+                exitSuccess -- See #3215.++        else return $! (ComponentNames names)++benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)+                   -> [String] -> GlobalFlags+                   -> IO ()+benchmarkAction+  (benchmarkFlags, buildFlags, buildExFlags)+  extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal+                       (benchmarkVerbosity benchmarkFlags)++  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)+  let buildFlags'    = buildFlags+                      { buildVerbosity = benchmarkVerbosity benchmarkFlags }+      noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck+                      (buildOnly buildExFlags)++  let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->+        if fromFlagOrDefault False (configBenchmarks configFlags)+          then pure (mempty, flags)+          else do+            info verbosity "reconfiguring to enable benchmarks"+            let flags' = ( configFlags { configBenchmarks = toFlag True }+                        , configExFlags+                        )+            pure (Any True, flags')+++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    checkFlags [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+        benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }++    -- The package was just configured, so the LBI must be available.+    names <- componentNamesFromLBI verbosity distPref "benchmarks"+            (\c -> case c of { LBI.CBench{} -> True; _ -> False; })+    let extraArgs'+          | null extraArgs = case names of+            ComponentNamesUnknown -> []+            ComponentNames names' -> [ Make.unUnqualComponentName name+                                    | LBI.CBenchName name <- names']+          | otherwise      = extraArgs++    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config' distPref buildFlags' extraArgs'++    maybeWithSandboxDirOnSearchPath useSandbox $+      setupWrapper verbosity setupOptions Nothing+      Cabal.benchmarkCommand (const benchmarkFlags') extraArgs'++haddockAction :: HaddockFlags -> [String] -> Action+haddockAction haddockFlags extraArgs globalFlags = do+  let verbosity = fromFlag (haddockVerbosity haddockFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (haddockDistPref haddockFlags)+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag+    mempty [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let haddockFlags' = defaultHaddockFlags      `mappend`+                        savedHaddockFlags config' `mappend`+                        haddockFlags { haddockDistPref = toFlag distPref }+        setupScriptOptions = defaultSetupScriptOptions+                             { useDistPref = distPref }+    setupWrapper verbosity setupScriptOptions Nothing+      haddockCommand (const haddockFlags') extraArgs+    when (haddockForHackage haddockFlags == Flag ForHackage) $ do+      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)+      let dest = distPref </> name <.> "tar.gz"+          name = display (packageId pkg) ++ "-docs"+          docDir = distPref </> "doc" </> "html"+      createTarGzFile dest docDir name+      notice verbosity $ "Documentation tarball created: " ++ dest++doctestAction :: DoctestFlags -> [String] -> Action+doctestAction doctestFlags extraArgs _globalFlags = do+  let verbosity = fromFlag (doctestVerbosity doctestFlags)++  setupWrapper verbosity defaultSetupScriptOptions Nothing+    doctestCommand (const doctestFlags) extraArgs++cleanAction :: CleanFlags -> [String] -> Action+cleanAction cleanFlags extraArgs globalFlags = do+  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+  let config = either (\(SomeException _) -> mempty) snd load+  distPref <- findSavedDistPref config (cleanDistPref cleanFlags)+  let setupScriptOptions = defaultSetupScriptOptions+                           { useDistPref = distPref+                           , useWin32CleanHack = True+                           }+      cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }+  setupWrapper verbosity setupScriptOptions Nothing+               cleanCommand (const cleanFlags') extraArgs+  where+    verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)++listAction :: ListFlags -> [String] -> Action+listAction listFlags extraArgs globalFlags = do+  let verbosity = fromFlag (listVerbosity listFlags)+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` listPackageDBs listFlags+        }+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, _, progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.list verbosity+       (configPackageDB' configFlags)+       repoContext+       comp+       progdb+       listFlags+       extraArgs++infoAction :: InfoFlags -> [String] -> Action+infoAction infoFlags extraArgs globalFlags = do+  let verbosity = fromFlag (infoVerbosity infoFlags)+  targets <- readUserTargets verbosity extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` infoPackageDBs infoFlags+        }+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, _, progdb) <- configCompilerAuxEx configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.info verbosity+       (configPackageDB' configFlags)+       repoContext+       comp+       progdb+       globalFlags'+       infoFlags+       targets++updateAction :: UpdateFlags -> [String] -> Action+updateAction updateFlags extraArgs globalFlags = do+  let verbosity = fromFlag (updateVerbosity updateFlags)+  unless (null extraArgs) $+    die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    update verbosity updateFlags repoContext++upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+              -> [String] -> Action+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 "+ ++ "confusing and it often led to broken packages.\n"+ ++ "If you want the old upgrade behaviour then use the install command "+ ++ "with the --upgrade-dependencies flag (but check first with --dry-run "+ ++ "to see what would happen). This will try to pick the latest versions "+ ++ "of all dependencies, rather than the usual behaviour of trying to pick "+ ++ "installed versions of all dependencies. If you do use "+ ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "+ ++ "packages (e.g. by using appropriate --constraint= flags)."+ where+  verbosity = fromFlag (configVerbosity configFlags)++fetchAction :: FetchFlags -> [String] -> Action+fetchAction fetchFlags extraArgs globalFlags = do+  let verbosity = fromFlag (fetchVerbosity fetchFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    fetch verbosity+        (configPackageDB' configFlags)+        repoContext+        comp platform progdb globalFlags' fetchFlags+        targets++freezeAction :: FreezeFlags -> [String] -> Action+freezeAction freezeFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config NoFlag+  nixShell verbosity distPref globalFlags config $ do+    let configFlags  = savedConfigureFlags config+        globalFlags' = savedGlobalFlags config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAux' configFlags++    maybeWithSandboxPackageInfo+      verbosity configFlags globalFlags'+      comp platform progdb useSandbox $ \mSandboxPkgInfo ->+        maybeWithSandboxDirOnSearchPath useSandbox $+        withRepoContext verbosity globalFlags' $ \repoContext ->+          freeze verbosity+            (configPackageDB' configFlags)+            repoContext+            comp platform progdb+            mSandboxPkgInfo+            globalFlags' freezeFlags++genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()+genBoundsAction freezeFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config NoFlag+  nixShell verbosity distPref globalFlags config $ do+    let configFlags  = savedConfigureFlags config+        globalFlags' = savedGlobalFlags config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAux' configFlags++    maybeWithSandboxPackageInfo+      verbosity configFlags globalFlags'+      comp platform progdb useSandbox $ \mSandboxPkgInfo ->+        maybeWithSandboxDirOnSearchPath useSandbox $+        withRepoContext verbosity globalFlags' $ \repoContext ->+          genBounds verbosity+                (configPackageDB' configFlags)+                repoContext+                comp platform progdb+                mSandboxPkgInfo+                globalFlags' freezeFlags++outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO ()+outdatedAction outdatedFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (outdatedVerbosity outdatedFlags)+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, _progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    outdated verbosity outdatedFlags repoContext+             comp platform++uploadAction :: UploadFlags -> [String] -> Action+uploadAction uploadFlags extraArgs globalFlags = do+  config <- loadConfig verbosity (globalConfigFile globalFlags)+  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+      tarfiles     = extraArgs+  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $+    die' verbosity "the 'upload' command expects at least one .tar.gz archive."+  checkTarFiles extraArgs+  maybe_password <-+    case uploadPasswordCmd uploadFlags'+    of Flag (xs:xss) -> Just . Password <$>+                        getProgramInvocationOutput verbosity+                        (simpleProgramInvocation xs xss)+       _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'+  withRepoContext verbosity globalFlags' $ \repoContext -> do+    if fromFlag (uploadDoc uploadFlags')+    then do+      when (length tarfiles > 1) $+       die' verbosity $ "the 'upload' command can only upload documentation "+             ++ "for one package at a time."+      tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles+      Upload.uploadDoc verbosity+                       repoContext+                       (flagToMaybe $ uploadUsername uploadFlags')+                       maybe_password+                       (fromFlag (uploadCandidate uploadFlags'))+                       tarfile+    else do+      Upload.upload verbosity+                    repoContext+                    (flagToMaybe $ uploadUsername uploadFlags')+                    maybe_password+                    (fromFlag (uploadCandidate uploadFlags'))+                    tarfiles+    where+    verbosity = fromFlag (uploadVerbosity uploadFlags)+    checkTarFiles tarfiles+      | not (null otherFiles)+      = die' verbosity $ "the 'upload' command expects only .tar.gz archives: "+           ++ intercalate ", " otherFiles+      | otherwise = sequence_+                      [ do exists <- doesFileExist tarfile+                           unless exists $ die' verbosity $ "file not found: " ++ tarfile+                      | tarfile <- tarfiles ]++      where otherFiles = filter (not . isTarGzFile) tarfiles+            isTarGzFile file = case splitExtension file of+              (file', ".gz") -> takeExtension file' == ".tar"+              _              -> False+    generateDocTarball config = do+      notice verbosity $+        "No documentation tarball specified. "+        ++ "Building a documentation tarball with default settings...\n"+        ++ "If you need to customise Haddock options, "+        ++ "run 'haddock --for-hackage' first "+        ++ "to generate a documentation tarball."+      haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage })+                    [] globalFlags+      distPref <- findSavedDistPref config NoFlag+      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)+      return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"++checkAction :: Flag Verbosity -> [String] -> Action+checkAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+  unless (null extraArgs) $+    die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs+  allOk <- Check.check (fromFlag verbosityFlag)+  unless allOk exitFailure++formatAction :: Flag Verbosity -> [String] -> Action+formatAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+  path <- case extraArgs of+    [] -> do cwd <- getCurrentDirectory+             tryFindPackageDesc cwd+    (p:_) -> return p+  pkgDesc <- readGenericPackageDescription verbosity path+  -- Uses 'writeFileAtomic' under the hood.+  writeGenericPackageDescription path pkgDesc++uninstallAction :: Flag Verbosity -> [String] -> Action+uninstallAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+      package = case extraArgs of+        p:_ -> p+        _   -> "PACKAGE_NAME"+  die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' "+    ++ "operation. "+    ++ "It will likely be implemented at some point in the future; "+    ++ "in the meantime you're advised to use either 'ghc-pkg unregister "+    ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."+++sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action+sdistAction (sdistFlags, sdistExFlags) 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++reportAction :: ReportFlags -> [String] -> Action+reportAction reportFlags extraArgs globalFlags = do+  let verbosity = fromFlag (reportVerbosity reportFlags)+  unless (null extraArgs) $+    die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+      reportFlags' = savedReportFlags config `mappend` reportFlags++  withRepoContext verbosity globalFlags' $ \repoContext ->+   Upload.report verbosity repoContext+    (flagToMaybe $ reportUsername reportFlags')+    (flagToMaybe $ reportPassword reportFlags')++runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action+runAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (buildDistPref buildFlags)+  let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)+  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    mempty [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    lbi <- getPersistBuildConfig distPref+    (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs++    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]++    maybeWithSandboxDirOnSearchPath useSandbox $+      run verbosity lbi exe exeArgs++getAction :: GetFlags -> [String] -> Action+getAction getFlags extraArgs globalFlags = do+  let verbosity = fromFlag (getVerbosity getFlags)+  targets <- readUserTargets verbosity extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->+   get verbosity+    repoContext+    globalFlags'+    getFlags+    targets++unpackAction :: GetFlags -> [String] -> Action+unpackAction getFlags extraArgs globalFlags = do+  getAction getFlags extraArgs globalFlags++initAction :: InitFlags -> [String] -> Action+initAction initFlags extraArgs globalFlags = do+  let verbosity = fromFlag (initVerbosity initFlags)+  when (extraArgs /= []) $+    die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let configFlags  = savedConfigureFlags config+  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, _, progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    initCabal verbosity+            (configPackageDB' configFlags)+            repoContext+            comp+            progdb+            initFlags++sandboxAction :: SandboxFlags -> [String] -> Action+sandboxAction sandboxFlags extraArgs globalFlags = do+  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)+  case extraArgs of+    -- Basic sandbox commands.+    ["init"] -> sandboxInit verbosity sandboxFlags globalFlags+    ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags+    ("add-source":extra) -> do+        when (noExtraArgs extra) $+          die' verbosity "The 'sandbox add-source' command expects at least one argument"+        sandboxAddSource verbosity extra sandboxFlags globalFlags+    ("delete-source":extra) -> do+        when (noExtraArgs extra) $+          die' verbosity ("The 'sandbox delete-source' command expects " +++              "at least one argument")+        sandboxDeleteSource verbosity extra sandboxFlags globalFlags+    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags++    -- More advanced commands.+    ("hc-pkg":extra) -> do+        when (noExtraArgs extra) $+            die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument"+        sandboxHcPkg verbosity sandboxFlags globalFlags extra+    ["buildopts"] -> die' verbosity "Not implemented!"++    -- Hidden commands.+    ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags++    -- Error handling.+    [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')"+    _  -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs++  where+    noExtraArgs = (<1) . length++execAction :: ExecFlags -> [String] -> Action+execAction execFlags extraArgs globalFlags = do+  let verbosity = fromFlag (execVerbosity execFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (execDistPref execFlags)+  let configFlags = savedConfigureFlags config+      configFlags' = configFlags { configDistPref = Flag distPref }+  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags'+  exec verbosity useSandbox comp platform progdb extraArgs++userConfigAction :: UserConfigFlags -> [String] -> Action+userConfigAction ucflags extraArgs globalFlags = do+  let verbosity  = fromFlag (userConfigVerbosity ucflags)+      force      = fromFlag (userConfigForce ucflags)+      extraLines = fromFlag (userConfigAppendLines ucflags)+  case extraArgs of+    ("init":_) -> do+      path       <- configFile+      fileExists <- doesFileExist path+      if (not fileExists || (fileExists && force))+      then void $ createDefaultConfigFile verbosity extraLines path+      else die' verbosity $ path ++ " already exists."+    ("diff":_) -> mapM_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines+    ("update":_) -> userConfigUpdate verbosity globalFlags extraLines+    -- Error handling.+    [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')"+    _  -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs+  where configFile = getConfigFilePath (globalConfigFile globalFlags)++-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.+--+win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action+win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do+  let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)+  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse+win32SelfUpgradeAction _ _ _ = return ()++-- | Used as an entry point when cabal-install needs to invoke itself+-- as a setup script. This can happen e.g. when doing parallel builds.+--+actAsSetupAction :: ActAsSetupFlags -> [String] -> Action+actAsSetupAction actAsSetupFlags args _globalFlags =+  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)+  in case bt of+    Simple    -> Simple.defaultMainArgs args+    Configure -> Simple.defaultMainWithHooksArgs+                  Simple.autoconfUserHooks args+    Make      -> Make.defaultMainArgs args+    Custom    -> error "actAsSetupAction Custom"++manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action+manpageAction commands flagVerbosity extraArgs _ = do+  let verbosity = fromFlag flagVerbosity+  unless (null extraArgs) $+    die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs+  pname <- getProgName+  let cabalCmd = if takeExtension pname == ".exe"+                 then dropExtension pname+                 else pname+  putStrLn $ manpage cabalCmd commands

tests/IntegrationTests2.hs view

@@ -18,7 +18,8 @@ import Distribution.Client.ProjectOrchestration          ( resolveTargets, TargetProblemCommon(..), distinctTargetComponents ) import Distribution.Client.Types-         ( PackageLocation(..), UnresolvedSourcePackage )+         ( PackageLocation(..), UnresolvedSourcePackage+         , PackageSpecifier(..) ) import Distribution.Client.Targets          ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -148,7 +149,7 @@      reportSubCase "cwd"     do Right ts <- readTargetSelectors' []-       ts @?= [TargetPackage TargetImplicitCwd "p-0.1" Nothing]+       ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing]      reportSubCase "all"     do Right ts <- readTargetSelectors'@@ -163,7 +164,7 @@                      , "tests", ":cwd:tests"                      , "benchmarks", ":cwd:benchmarks"]        zipWithM_ (@?=) ts-         [ TargetPackage TargetImplicitCwd "p-0.1" (Just kind)+         [ TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind)          | kind <- concatMap (replicate 2) [LibKind .. ]          ] @@ -199,10 +200,10 @@                      , "q:tests", "q/:tests", ":pkg:q:tests"                      , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"]        zipWithM_ (@?=) ts $-         [ TargetPackage TargetExplicitNamed "p-0.1" (Just kind)+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind)          | kind <- concatMap (replicate 3) [LibKind .. ]          ] ++-         [ TargetPackage TargetExplicitNamed "q-0.1" (Just kind)+         [ TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind)          | kind <- concatMap (replicate 3) [LibKind .. ]          ] @@ -288,19 +289,19 @@     reportSubCase "ambiguous: cwd-pkg filter vs pkg"     assertAmbiguous "libs"       [ mkTargetPackage "libs"-      , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just LibKind) ]+      , TargetPackage TargetImplicitCwd ["libs"] (Just LibKind) ]       [mkpkg "libs" []]      reportSubCase "ambiguous: filter vs cwd component"     assertAmbiguous "exes"       [ mkTargetComponent "other" (CExeName "exes")-      , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just ExeKind) ]+      , TargetPackage TargetImplicitCwd ["other"] (Just ExeKind) ]       [mkpkg "other" [mkexe "exes"]]      -- but filters are not ambiguous with non-cwd components, modules or files     reportSubCase "unambiguous: filter vs non-cwd comp, mod, file"     assertUnambiguous "Libs"-      (TargetPackage TargetImplicitCwd "bar" (Just LibKind))+      (TargetPackage TargetImplicitCwd ["bar"] (Just LibKind))       [ mkpkgAt "foo" [mkexe "Libs"] "foo"       , mkpkg   "bar" [ mkexe "bar" `withModules` ["Libs"]                       , mkexe "baz" `withCFiles` ["Libs"] ]@@ -366,11 +367,14 @@       ]   where     assertAmbiguous :: String-                    -> [TargetSelector PackageId]+                    -> [TargetSelector]                     -> [SourcePackage (PackageLocation a)]                     -> Assertion     assertAmbiguous str tss pkgs = do-      res <- readTargetSelectorsWith fakeDirActions pkgs [str]+      res <- readTargetSelectorsWith+               fakeDirActions+               (map SpecificSourcePackage pkgs)+               [str]       case res of         Left [TargetSelectorAmbiguous _ tss'] ->           sort (map snd tss') @?= sort tss@@ -378,11 +382,14 @@                           ++ "got " ++ show res      assertUnambiguous :: String-                      -> TargetSelector PackageId+                      -> TargetSelector                       -> [SourcePackage (PackageLocation a)]                       -> Assertion     assertUnambiguous str ts pkgs = do-      res <- readTargetSelectorsWith fakeDirActions pkgs [str]+      res <- readTargetSelectorsWith+               fakeDirActions+               (map SpecificSourcePackage pkgs)+               [str]       case res of         Right [ts'] -> ts' @?= ts         _ -> assertFailure $ "expected Right [Target...], "@@ -432,23 +439,23 @@       exe { buildInfo = (buildInfo exe) { cSources = files } }  -mkTargetPackage :: PackageId -> TargetSelector PackageId+mkTargetPackage :: PackageId -> TargetSelector mkTargetPackage pkgid =-    TargetPackage TargetExplicitNamed pkgid Nothing+    TargetPackage TargetExplicitNamed [pkgid] Nothing -mkTargetComponent :: PackageId -> ComponentName -> TargetSelector PackageId+mkTargetComponent :: PackageId -> ComponentName -> TargetSelector mkTargetComponent pkgid cname =     TargetComponent pkgid cname WholeComponent -mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector PackageId+mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector mkTargetModule pkgid cname mname =     TargetComponent pkgid cname (ModuleTarget mname) -mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector PackageId+mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector mkTargetFile pkgid cname fname =     TargetComponent pkgid cname (FileTarget fname) -mkTargetAllPackages :: TargetSelector PackageId+mkTargetAllPackages :: TargetSelector mkTargetAllPackages = TargetAllPackages Nothing  instance IsString PackageIdentifier where@@ -509,8 +516,8 @@                      [ (packageName p, packageId p)                      | p <- InstallPlan.toList elaboratedPlan ] -        cases :: [( TargetSelector PackageId -> CmdBuild.TargetProblem-                  , TargetSelector PackageId+        cases :: [( TargetSelector -> CmdBuild.TargetProblem+                  , TargetSelector                   )]         cases =           [ -- Cannot resolve packages outside of the project@@ -666,8 +673,8 @@          CmdBuild.selectPackageTargets          CmdBuild.selectComponentTarget          CmdBuild.TargetProblemCommon-         [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind)-         , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind)+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)+         , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)          ]          [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")          , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")@@ -719,7 +726,7 @@                , AvailableTarget "p-0.1" (CTestName "p1")                    (TargetBuildable () TargetNotRequestedByDefault) True                ]-        , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) )+        , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) )       ]      reportSubCase "multiple targets"@@ -789,7 +796,7 @@          CmdRepl.selectPackageTargets          CmdRepl.selectComponentTarget          CmdRepl.TargetProblemCommon-         [ TargetPackage TargetExplicitNamed "p-0.1" Nothing ]+         [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ]          [ ("p-0.1-inplace", CLibName) ]        -- When we select the package with an explicit filter then we get those        -- components even though we did not explicitly enable tests/benchmarks@@ -798,14 +805,14 @@          CmdRepl.selectPackageTargets          CmdRepl.selectComponentTarget          CmdRepl.TargetProblemCommon-         [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ]+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ]          [ ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite") ]        assertProjectDistinctTargets          elaboratedPlan          CmdRepl.selectPackageTargets          CmdRepl.selectComponentTarget          CmdRepl.TargetProblemCommon-         [ TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) ]+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ]          [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ]  @@ -862,45 +869,16 @@       [ ( CmdRun.TargetProblemNoTargets, mkTargetPackage "p-0.1" )       ] -    reportSubCase "test-only"+    reportSubCase "lib-only"     assertProjectTargetProblems-      "targets/test-only" config+      "targets/lib-only" config       CmdRun.selectPackageTargets       CmdRun.selectComponentTarget       CmdRun.TargetProblemCommon       [ ( CmdRun.TargetProblemNoExes, mkTargetPackage "p-0.1" )       ] -    reportSubCase "variety"-    assertProjectTargetProblems-      "targets/variety" config-      CmdRun.selectPackageTargets-      CmdRun.selectComponentTarget-      CmdRun.TargetProblemCommon $-      [ ( const (CmdRun.TargetProblemComponentNotExe "p-0.1" cname)-        , mkTargetComponent "p-0.1" cname )-      | cname <- [ CLibName, CFLibName "libp",-                   CTestName "a-testsuite", CBenchName "a-benchmark" ]-      ] ++-      [ ( const (CmdRun.TargetProblemIsSubComponent-                          "p-0.1" cname (ModuleTarget modname))-        , mkTargetModule "p-0.1" cname modname )-      | (cname, modname) <- [ (CTestName  "a-testsuite", "TestModule")-                            , (CBenchName "a-benchmark", "BenchModule")-                            , (CExeName   "an-exe",      "ExeModule")-                            , (CLibName,                 "P")-                            ]-      ] ++-      [ ( const (CmdRun.TargetProblemIsSubComponent-                          "p-0.1" cname (FileTarget fname))-        , mkTargetFile "p-0.1" cname fname)-      | (cname, fname) <- [ (CTestName  "a-testsuite", "Test.hs")-                          , (CBenchName "a-benchmark", "Bench.hs")-                          , (CExeName   "an-exe",      "Main.hs")-                          ]-      ] - testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion testTargetProblemsTest config reportSubCase = do @@ -1188,10 +1166,10 @@           (CmdHaddock.selectPackageTargets haddockFlags)           CmdHaddock.selectComponentTarget           CmdHaddock.TargetProblemCommon-          [ TargetPackage TargetExplicitNamed "p-0.1" (Just FLibKind)-          , TargetPackage TargetExplicitNamed "p-0.1" (Just ExeKind)-          , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind)-          , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind)+          [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just FLibKind)+          , TargetPackage TargetExplicitNamed ["p-0.1"] (Just ExeKind)+          , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)+          , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)           ]           [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")           , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")@@ -1210,10 +1188,10 @@ assertProjectDistinctTargets   :: forall err. (Eq err, Show err) =>      ElaboratedInstallPlan-  -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k])-  -> (forall k. PackageId -> ComponentName -> SubComponentTarget ->  AvailableTarget k  -> Either err  k )+  -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k])+  -> (forall k. SubComponentTarget ->  AvailableTarget k  -> Either err  k )   -> (TargetProblemCommon -> err)-  -> [TargetSelector PackageId]+  -> [TargetSelector]   -> [(UnitId, ComponentName)]   -> Assertion assertProjectDistinctTargets elaboratedPlan@@ -1240,14 +1218,14 @@ assertProjectTargetProblems   :: forall err. (Eq err, Show err) =>      FilePath -> ProjectConfig-  -> (forall k. TargetSelector PackageId+  -> (forall k. TargetSelector              -> [AvailableTarget k]              -> Either err [k])-  -> (forall k. PackageId -> ComponentName -> SubComponentTarget+  -> (forall k. SubComponentTarget              -> AvailableTarget k              -> Either err k )   -> (TargetProblemCommon -> err)-  -> [(TargetSelector PackageId -> err, TargetSelector PackageId)]+  -> [(TargetSelector -> err, TargetSelector)]   -> Assertion assertProjectTargetProblems testdir config                             selectPackageTargets@@ -1266,10 +1244,10 @@ assertTargetProblems   :: forall err. (Eq err, Show err) =>      ElaboratedInstallPlan-  -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k])-  -> (forall k. PackageId -> ComponentName -> SubComponentTarget ->  AvailableTarget k  -> Either err  k )+  -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k])+  -> (forall k. SubComponentTarget ->  AvailableTarget k  -> Either err  k )   -> (TargetProblemCommon -> err)-  -> [(TargetSelector PackageId -> err, TargetSelector PackageId)]+  -> [(TargetSelector -> err, TargetSelector)]   -> Assertion assertTargetProblems elaboratedPlan                      selectPackageTargets@@ -1369,14 +1347,16 @@     marker1 @?= "ok"     removeFile (basedir </> testdir1 </> "marker") -    reportSubCase (show SetupCustomImplicitDeps)-    (plan2, res2) <- executePlan =<< planProject testdir2 config-    (pkg2,  _)    <- expectPackageInstalled plan2 res2 pkgidA-    elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps-    hasDefaultSetupDeps pkg2 @?= Just True-    marker2 <- readFile (basedir </> testdir2 </> "marker")-    marker2 @?= "ok"-    removeFile (basedir </> testdir2 </> "marker")+    -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later+    when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8,2]) $ do+      reportSubCase (show SetupCustomImplicitDeps)+      (plan2, res2) <- executePlan =<< planProject testdir2 config+      (pkg2,  _)    <- expectPackageInstalled plan2 res2 pkgidA+      elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps+      hasDefaultSetupDeps pkg2 @?= Just True+      marker2 <- readFile (basedir </> testdir2 </> "marker")+      marker2 @?= "ok"+      removeFile (basedir </> testdir2 </> "marker")      reportSubCase (show SetupNonCustomInternalLib)     (plan3, res3) <- executePlan =<< planProject testdir3 config@@ -1478,7 +1458,7 @@ type ProjDetails = (DistDirLayout,                     CabalDirLayout,                     ProjectConfig,-                    [UnresolvedSourcePackage],+                    [PackageSpecifier UnresolvedSourcePackage],                     BuildTimeSettings)  configureProject :: FilePath -> ProjectConfig -> IO ProjDetails

+ tests/IntegrationTests2/targets/lib-only/p.cabal view

@@ -0,0 +1,8 @@+name: p+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: P+  build-depends: base

tests/UnitTests.hs view

@@ -9,7 +9,7 @@  import Distribution.Compat.Time -import qualified UnitTests.Distribution.Solver.Modular.PSQ+import qualified UnitTests.Distribution.Solver.Modular.Builder import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ import qualified UnitTests.Distribution.Solver.Modular.Solver import qualified UnitTests.Distribution.Solver.Modular.RetryLog@@ -38,8 +38,8 @@                     else mtimeChangeCalibrated   in   testGroup "Unit Tests"-  [ testGroup "UnitTests.Distribution.Solver.Modular.PSQ"-        UnitTests.Distribution.Solver.Modular.PSQ.tests+  [ testGroup "UnitTests.Distribution.Solver.Modular.Builder"+        UnitTests.Distribution.Solver.Modular.Builder.tests   , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ"         UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests   , testGroup "UnitTests.Distribution.Solver.Modular.Solver"

tests/UnitTests/Distribution/Client/ProjectConfig.hs view

@@ -16,6 +16,7 @@ import Distribution.Compiler import Distribution.Version import Distribution.ParseUtils+import Distribution.Text as Text import Distribution.Simple.Compiler import Distribution.Simple.Setup import Distribution.Simple.InstallDirs@@ -63,6 +64,9 @@    , testGroup "individual parser tests"     [ testProperty "package location"  prop_parsePackageLocationTokenQ+    , testProperty "RelaxedDep"        prop_roundtrip_printparse_RelaxedDep+    , testProperty "RelaxDeps"         prop_roundtrip_printparse_RelaxDeps+    , testProperty "RelaxDeps'"        prop_roundtrip_printparse_RelaxDeps'     ]    , testGroup "ProjectConfig printing/parsing round trip"@@ -200,11 +204,12 @@ hackProjectConfigShared config =     config {       projectConfigProjectFile = mempty, -- not present within project files+      projectConfigConfigFile  = mempty, -- ditto       projectConfigConstraints =       --TODO: [required eventually] parse ambiguity in constraint       -- "pkgname -any" as either any version or disabled flag "any".         let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) =-              (not . null) [ () | (name, False) <- flags+              (not . null) [ () | (name, False) <- unFlagAssignment flags                                 , "any" `isPrefixOf` unFlagName name ]             ambiguous _ = False          in filter (not . ambiguous) (projectConfigConstraints config)@@ -228,17 +233,42 @@   ------------------------------- Individual Parser tests +-- Individual Parser tests -- +-- | Helper to parse a given string+--+-- Succeeds only if there is a unique complete parse+runReadP :: Parse.ReadP a a -> String -> Maybe a+runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of+                      [x'] -> Just x'+                      _    -> Nothing+ prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool prop_parsePackageLocationTokenQ (PackageLocationString str) =-    case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ-                                         (renderPackageLocationToken str) ] of-      [str'] -> str' == str-      _      -> False+    runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str +prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Bool+prop_roundtrip_printparse_RelaxedDep rdep =+    runReadP Text.parse (Text.display rdep) == Just rdep +prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Bool+prop_roundtrip_printparse_RelaxDeps rdep =+    runReadP Text.parse (Text.display rdep) == Just rdep++prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Bool+prop_roundtrip_printparse_RelaxDeps' rdep =+    runReadP Text.parse (go $ Text.display rdep) == Just rdep+  where+    -- replace 'all' tokens by '*'+    go :: String -> String+    go [] = []+    go "all" = "*"+    go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest)+    go rest = let (x,y) = break (`elem` ":,") rest+                  (x',y') = span (`elem` ":,^") y+              in x++x'++go y'+ ------------------------ -- Arbitrary instances --@@ -254,17 +284,36 @@         <*> arbitrary         <*> arbitrary         <*> arbitrary+        <*> arbitrary         <*> (MapMappend . fmap getNonMEmpty . Map.fromList                <$> shortListOf 3 arbitrary)         -- package entries with no content are equivalent to         -- the entry not existing at all, so exclude empty -    shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7 x8) =-      [ ProjectConfig x0' x1' x2' x3'-                      x4' x5' x6' x7' (MapMappend (fmap getNonMEmpty x8'))-      | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8'))+    shrink ProjectConfig { projectPackages = x0+                         , projectPackagesOptional = x1+                         , projectPackagesRepo = x2+                         , projectPackagesNamed = x3+                         , projectConfigBuildOnly = x4+                         , projectConfigShared = x5+                         , projectConfigProvenance = x6+                         , projectConfigLocalPackages = x7+                         , projectConfigSpecificPackage = x8+                         , projectConfigAllPackages = x9 } =+      [ ProjectConfig { projectPackages = x0'+                      , projectPackagesOptional = x1'+                      , projectPackagesRepo = x2'+                      , projectPackagesNamed = x3'+                      , projectConfigBuildOnly = x4'+                      , projectConfigShared = x5'+                      , projectConfigProvenance = x6'+                      , projectConfigLocalPackages = x7'+                      , projectConfigSpecificPackage = (MapMappend+                                                         (fmap getNonMEmpty x8'))+                      , projectConfigAllPackages = x9' }+      | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9'))           <- shrink ((x0, x1, x2, x3),-                     (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8)))+                      (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9))       ]  newtype PackageLocationString@@ -370,6 +419,7 @@       ProjectConfigShared         <$> arbitraryFlag arbitraryShortToken         <*> arbitraryFlag arbitraryShortToken+        <*> arbitraryFlag arbitraryShortToken         <*> arbitrary         <*> arbitraryFlag arbitraryShortToken         <*> arbitraryFlag arbitraryShortToken@@ -385,44 +435,87 @@         <*> arbitrary <*> arbitrary         <*> arbitrary         <*> arbitrary+        <*> arbitrary+        <*> (toNubList <$> listOf arbitraryShortToken)       where         arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]         arbitraryConstraints =-            map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary+            fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary -    shrink (ProjectConfigShared-              x00 x01 x02 x03 x04-              x05 x06 x07 x08 x09-              x10 x11 x12 x13 x14-              x15 x16 x17 x18 x19-              x20) =-      [ ProjectConfigShared-          x00' x01' x02' (fmap getNonEmpty x03') (fmap getNonEmpty x04')-          x05' x06' x07' x08' (postShrink_Constraints x09')-          x10' x11' x12' x13' x14' x15' x16' x17' x18' x19' x20'+    shrink ProjectConfigShared { projectConfigDistDir = x00+                               , projectConfigProjectFile = x01+                               , projectConfigHcFlavor = x02+                               , projectConfigHcPath = x03+                               , projectConfigHcPkg = x04+                               , projectConfigHaddockIndex = x05+                               , projectConfigRemoteRepos = x06+                               , projectConfigLocalRepos = x07+                               , projectConfigIndexState = x08+                               , projectConfigConstraints = x09+                               , projectConfigPreferences = x10+                               , projectConfigCabalVersion = x11+                               , projectConfigSolver = x12+                               , projectConfigAllowOlder = x13+                               , projectConfigAllowNewer = x14+                               , projectConfigMaxBackjumps = x15+                               , projectConfigReorderGoals = x16+                               , projectConfigCountConflicts = x17+                               , projectConfigStrongFlags = x18+                               , projectConfigAllowBootLibInstalls = x19+                               , projectConfigPerComponent = x20+                               , projectConfigIndependentGoals = x21+                               , projectConfigConfigFile = x22+                               , projectConfigProgPathExtra = x23} =+      [ ProjectConfigShared { projectConfigDistDir = x00'+                            , projectConfigProjectFile = x01'+                            , projectConfigHcFlavor = x02'+                            , projectConfigHcPath = fmap getNonEmpty x03'+                            , projectConfigHcPkg = fmap getNonEmpty x04'+                            , projectConfigHaddockIndex = x05'+                            , projectConfigRemoteRepos = x06'+                            , projectConfigLocalRepos = x07'+                            , projectConfigIndexState = x08'+                            , projectConfigConstraints = postShrink_Constraints x09'+                            , projectConfigPreferences = x10'+                            , projectConfigCabalVersion = x11'+                            , projectConfigSolver = x12'+                            , projectConfigAllowOlder = x13'+                            , projectConfigAllowNewer = x14'+                            , projectConfigMaxBackjumps = x15'+                            , projectConfigReorderGoals = x16'+                            , projectConfigCountConflicts = x17'+                            , projectConfigStrongFlags = x18'+                            , projectConfigAllowBootLibInstalls = x19'+                            , projectConfigPerComponent = x20'+                            , projectConfigIndependentGoals = x21'+                            , projectConfigConfigFile = x22'+                            , projectConfigProgPathExtra = x23'}       | ((x00', x01', x02', x03', x04'),          (x05', x06', x07', x08', x09'),          (x10', x11', x12', x13', x14'),          (x15', x16', x17', x18', x19'),-         x20')+          x20', x21', x22', x23')           <- shrink                ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04),                 (x05, x06, x07, x08, preShrink_Constraints x09),                 (x10, x11, x12, x13, x14),                 (x15, x16, x17, x18, x19),-                x20)+                 x20, x21, x22, x23)       ]       where         preShrink_Constraints  = map fst         postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))  projectConfigConstraintSource :: ConstraintSource-projectConfigConstraintSource = +projectConfigConstraintSource =     ConstraintSourceProjectConfig "TODO"  instance Arbitrary ProjectConfigProvenance where     arbitrary = elements [Implicit, Explicit "cabal.project"] +instance Arbitrary FlagAssignment where+    arbitrary = mkFlagAssignment <$> arbitrary+ instance Arbitrary PackageConfig where     arbitrary =       PackageConfig@@ -434,7 +527,7 @@                    <*> listOf arbitraryShortToken))         <*> (toNubList <$> listOf arbitraryShortToken)         <*> arbitrary-        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary@@ -444,13 +537,13 @@         <*> shortListOf 5 arbitraryShortToken         <*> shortListOf 5 arbitraryShortToken         <*> shortListOf 5 arbitraryShortToken-        <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary         <*> arbitraryFlag arbitraryShortToken         <*> arbitrary         <*> arbitrary@@ -460,59 +553,125 @@         <*> arbitrary         <*> arbitraryFlag arbitraryShortToken         <*> arbitrary+        <*> arbitrary       where         arbitraryProgramName :: Gen String         arbitraryProgramName =           elements [ programName prog                    | (prog, _) <- knownPrograms (defaultProgramDb) ] -    shrink (PackageConfig-              x00 x01 x02 x03 x04-              x05 x06 x07 x08 x09-              x10 x11 x12 x13 x14-              x15 x16 x17 x18 x19-              x20 x21 x22 x23 x24-              x25 x26 x27 x28 x29-              x30 x31 x32 x33 x33_1 x34-              x35 x36 x37 x38 x39-              x40) =-      [ PackageConfig-          (postShrink_Paths x00')-          (postShrink_Args  x01') x02' x03' x04'-          x05' x06' x07' x08' x09'-          x10' x11' (map getNonEmpty x12') x13' x14'-          x15' (map getNonEmpty x16')-               (map getNonEmpty x17')-               (map getNonEmpty x18')-                              x19'-          x20' x21' x22' x23' x24'-          x25' x26' x27' x28' x29'-          x30' x31' x32' x33' x33_1' x34'-          x35' x36' (fmap getNonEmpty x37') x38'-                    (fmap getNonEmpty x39')-          x40'-      | (((x00', x01', x02', x03', x04'),-          (x05', x06', x07', x08', x09'),+    shrink PackageConfig { packageConfigProgramPaths = x00+                         , packageConfigProgramArgs = x01+                         , packageConfigProgramPathExtra = x02+                         , packageConfigFlagAssignment = x03+                         , packageConfigVanillaLib = x04+                         , packageConfigSharedLib = x05+                         , packageConfigStaticLib = x42+                         , packageConfigDynExe = x06+                         , packageConfigProf = x07+                         , packageConfigProfLib = x08+                         , packageConfigProfExe = x09+                         , packageConfigProfDetail = x10+                         , packageConfigProfLibDetail = x11+                         , packageConfigConfigureArgs = x12+                         , packageConfigOptimization = x13+                         , packageConfigProgPrefix = x14+                         , packageConfigProgSuffix = x15+                         , packageConfigExtraLibDirs = x16+                         , packageConfigExtraFrameworkDirs = x17+                         , packageConfigExtraIncludeDirs = x18+                         , packageConfigGHCiLib = x19+                         , packageConfigSplitSections = x20+                         , packageConfigSplitObjs = x20_1+                         , packageConfigStripExes = x21+                         , packageConfigStripLibs = x22+                         , packageConfigTests = x23+                         , packageConfigBenchmarks = x24+                         , packageConfigCoverage = x25+                         , packageConfigRelocatable = x26+                         , packageConfigDebugInfo = x27+                         , packageConfigRunTests = x28+                         , packageConfigDocumentation = x29+                         , packageConfigHaddockHoogle = x30+                         , packageConfigHaddockHtml = x31+                         , packageConfigHaddockHtmlLocation = x32+                         , packageConfigHaddockForeignLibs = x33+                         , packageConfigHaddockExecutables = x33_1+                         , packageConfigHaddockTestSuites = x34+                         , packageConfigHaddockBenchmarks = x35+                         , packageConfigHaddockInternal = x36+                         , packageConfigHaddockCss = x37+                         , packageConfigHaddockLinkedSource = x38+                         , packageConfigHaddockHscolourCss = x39+                         , packageConfigHaddockContents = x40+                         , packageConfigHaddockForHackage = x41 } =+      [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00'+                      , packageConfigProgramArgs = postShrink_Args x01'+                      , packageConfigProgramPathExtra = x02'+                      , packageConfigFlagAssignment = x03'+                      , packageConfigVanillaLib = x04'+                      , packageConfigSharedLib = x05'+                      , packageConfigStaticLib = x42'+                      , packageConfigDynExe = x06'+                      , packageConfigProf = x07'+                      , packageConfigProfLib = x08'+                      , packageConfigProfExe = x09'+                      , packageConfigProfDetail = x10'+                      , packageConfigProfLibDetail = x11'+                      , packageConfigConfigureArgs = map getNonEmpty x12'+                      , packageConfigOptimization = x13'+                      , packageConfigProgPrefix = x14'+                      , packageConfigProgSuffix = x15'+                      , packageConfigExtraLibDirs = map getNonEmpty x16'+                      , packageConfigExtraFrameworkDirs = map getNonEmpty x17'+                      , packageConfigExtraIncludeDirs = map getNonEmpty x18'+                      , packageConfigGHCiLib = x19'+                      , packageConfigSplitSections = x20'+                      , packageConfigSplitObjs = x20_1'+                      , packageConfigStripExes = x21'+                      , packageConfigStripLibs = x22'+                      , packageConfigTests = x23'+                      , packageConfigBenchmarks = x24'+                      , packageConfigCoverage = x25'+                      , packageConfigRelocatable = x26'+                      , packageConfigDebugInfo = x27'+                      , packageConfigRunTests = x28'+                      , packageConfigDocumentation = x29'+                      , packageConfigHaddockHoogle = x30'+                      , packageConfigHaddockHtml = x31'+                      , packageConfigHaddockHtmlLocation = x32'+                      , packageConfigHaddockForeignLibs = x33'+                      , packageConfigHaddockExecutables = x33_1'+                      , packageConfigHaddockTestSuites = x34'+                      , packageConfigHaddockBenchmarks = x35'+                      , packageConfigHaddockInternal = x36'+                      , packageConfigHaddockCss = fmap getNonEmpty x37'+                      , packageConfigHaddockLinkedSource = x38'+                      , packageConfigHaddockHscolourCss = fmap getNonEmpty x39'+                      , packageConfigHaddockContents = x40'+                      , packageConfigHaddockForHackage = x41' }+      |  (((x00', x01', x02', x03', x04'),+          (x05', x42', x06', x07', x08', x09'),           (x10', x11', x12', x13', x14'),           (x15', x16', x17', x18', x19')),-         ((x20', x21', x22', x23', x24'),+         ((x20', x20_1', x21', x22', x23', x24'),           (x25', x26', x27', x28', x29'),           (x30', x31', x32', (x33', x33_1'), x34'),           (x35', x36', x37', x38', x39'),-          (x40')))+          (x40', x41')))           <- shrink-               (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04),-                 (x05, x06, x07, x08, x09),-                 (x10, x11, map NonEmpty x12, x13, x14),-                 (x15, map NonEmpty x16,-                       map NonEmpty x17,-                       map NonEmpty x18,-                       x19)),-                ((x20, x21, x22, x23, x24),+             (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04),+                (x05, x42, x06, x07, x08, x09),+                (x10, x11, map NonEmpty x12, x13, x14),+                (x15, map NonEmpty x16,+                  map NonEmpty x17,+                  map NonEmpty x18,+                  x19)),+               ((x20, x20_1, x21, x22, x23, x24),                  (x25, x26, x27, x28, x29),                  (x30, x31, x32, (x33, x33_1), x34),                  (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39),-                 (x40)))+                 (x40, x41)))       ]       where         preShrink_Paths  = Map.map NonEmpty@@ -528,6 +687,8 @@                          . Map.map (map getNonEmpty . getNonEmpty)                          . Map.mapKeys getNoShrink +instance Arbitrary HaddockTarget where+    arbitrary = elements [ForHackage, ForDevelopment]  instance Arbitrary SourceRepo where     arbitrary = (SourceRepo RepoThis@@ -620,7 +781,7 @@     arbitrary = oneof [ PackagePropertyVersion <$> arbitrary                       , pure PackagePropertyInstalled                       , pure PackagePropertySource-                      , PackagePropertyFlags <$> shortListOf1 3 arbitrary+                      , PackagePropertyFlags  . mkFlagAssignment <$> shortListOf1 3 arbitrary                       , PackagePropertyStanzas . (\x->[x]) <$> arbitrary                       ] @@ -643,6 +804,9 @@ instance Arbitrary CountConflicts where     arbitrary = CountConflicts <$> arbitrary +instance Arbitrary IndependentGoals where+    arbitrary = IndependentGoals <$> arbitrary+ instance Arbitrary StrongFlags where     arbitrary = StrongFlags <$> arbitrary @@ -656,16 +820,28 @@     arbitrary = AllowOlder <$> arbitrary  instance Arbitrary RelaxDeps where-    arbitrary = oneof [ pure RelaxDepsNone+    arbitrary = oneof [ pure mempty                       , RelaxDepsSome <$> shortListOf1 3 arbitrary                       , pure RelaxDepsAll                       ] -instance Arbitrary RelaxedDep where-    arbitrary = oneof [ RelaxedDep       <$> arbitrary-                      , RelaxedDepScoped <$> arbitrary <*> arbitrary+instance Arbitrary RelaxDepMod where+    arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]++instance Arbitrary RelaxDepScope where+    arbitrary = oneof [ pure RelaxDepScopeAll+                      , RelaxDepScopePackage <$> arbitrary+                      , RelaxDepScopePackageId <$> (PackageIdentifier <$> arbitrary <*> arbitrary)                       ] +instance Arbitrary RelaxDepSubject where+    arbitrary = oneof [ pure RelaxDepSubjectAll+                      , RelaxDepSubjectPkg <$> arbitrary+                      ]++instance Arbitrary RelaxedDep where+    arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary+ instance Arbitrary ProfDetailLevel where     arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] @@ -696,4 +872,3 @@ arbitraryURIPort :: Gen String arbitraryURIPort =     oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]-

tests/UnitTests/Distribution/Client/Store.hs view

@@ -51,7 +51,7 @@           let destprefix = dir </> "prefix"           createDirectory destprefix           writeFile (destprefix </> file) content-          return destprefix+          return (destprefix,[])      assertNewStoreEntry tmp storeDirLayout compid unitid1                         (copyFiles "file1" "content-foo") (return ())@@ -137,7 +137,7 @@  assertNewStoreEntry :: FilePath -> StoreDirLayout                     -> CompilerId -> UnitId-                    -> (FilePath -> IO FilePath) -> IO ()+                    -> (FilePath -> IO (FilePath,[FilePath])) -> IO ()                     -> NewStoreEntryOutcome                     -> Assertion assertNewStoreEntry tmp storeDirLayout compid unitid

tests/UnitTests/Distribution/Client/Tar.hs view

@@ -32,7 +32,7 @@       e2 = getFileEntry "file2" "y"       p = (\e -> let (NormalFile dta _) = entryContent e                      str = BS.Char8.unpack dta-                 in not . (=="y") $ str)+                 in str /= "y")   assertEqual "Unexpected result for filter" "xz" $     entriesToString $ filterEntries p $ Next e1 $ Next e2 Done   assertEqual "Unexpected result for filter" "z" $@@ -46,7 +46,7 @@       e2 = getFileEntry "file2" "y"       p = (\e -> let (NormalFile dta _) = entryContent e                      str = BS.Char8.unpack dta-                 in tell "t" >> return (not . (=="y") $ str))+                 in tell "t" >> return (str /= "y"))    (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done   assertEqual "Unexpected result for filterM" "xz" $ entriesToString r

tests/UnitTests/Distribution/Client/Targets.hs view

@@ -7,7 +7,7 @@                                        ,UserConstraint(..), readUserConstraint) import Distribution.Compat.ReadP       (readP_to_S) import Distribution.Package            (mkPackageName)-import Distribution.PackageDescription (mkFlagName)+import Distribution.PackageDescription (mkFlagName, mkFlagAssignment) import Distribution.Version            (anyVersion, thisVersion, mkVersion) import Distribution.ParseUtils         (parseCommaList) import Distribution.Text               (parse)@@ -31,10 +31,10 @@ tests =   [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest)       exampleConstraints-    +   , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest)       exampleConstraints-  +   , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest)       [-- First example only.        (head exampleStrs, take 1 exampleUcs),@@ -49,7 +49,7 @@   [ ("template-haskell installed",      UserConstraint (UserQualified UserQualToplevel (pn "template-haskell"))                     PackagePropertyInstalled)-    +   , ("bytestring -any",      UserConstraint (UserQualified UserQualToplevel (pn "bytestring"))                     (PackagePropertyVersion anyVersion))@@ -65,13 +65,14 @@   , ("process:setup.bytestring ==5.2",      UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring"))                     (PackagePropertyVersion (thisVersion (mkVersion [5, 2]))))-    +   , ("network:setup.containers +foo -bar baz",      UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers"))-                    (PackagePropertyFlags [(fn "foo", True),+                    (PackagePropertyFlags (mkFlagAssignment+                                          [(fn "foo", True),                                            (fn "bar", False),-                                           (fn "baz", True)]))-    +                                           (fn "baz", True)])))+   -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.   --   -- , ("foo:happy:exe.template-haskell test",

tests/UnitTests/Distribution/Client/UserConfig.hs view

@@ -37,7 +37,7 @@     -- Create a new default config file in our test directory.     _ <- loadConfig silent (Flag configFile)     -- Now we read it in and compare it against the default.-    diff <- userConfigDiff $ globalFlags configFile+    diff <- userConfigDiff silent (globalFlags configFile) []     assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff  @@ -46,7 +46,7 @@     -- Create a new default config file in our test directory.     _ <- loadConfig silent (Flag configFile)     appendFile configFile "verbose: 0\n"-    diff <- userConfigDiff $ globalFlags configFile+    diff <- userConfigDiff silent (globalFlags configFile) []     assertBool (unlines $ "Should detect a difference:" : diff) $         diff == [ "+ verbose: 0" ] @@ -56,7 +56,7 @@     -- Write a trivial cabal file.     writeFile configFile "tests: True\n"     -- Update the config file.-    userConfigUpdate silent $ globalFlags configFile+    userConfigUpdate silent (globalFlags configFile) []     -- Load it again.     updated <- loadConfig silent (Flag configFile)     assertBool ("Field 'tests' should be True") $@@ -68,7 +68,7 @@     -- Create a new default config file in our test directory.     _ <- loadConfig silent (Flag configFile)     -- Update it twice.-    replicateM_ 2 . userConfigUpdate silent $ globalFlags configFile+    replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) []     -- Load it again.     updated <- loadConfig silent (Flag configFile) @@ -85,7 +85,7 @@     sysTmpDir <- getTemporaryDirectory     withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do         let configFile  = tmpDir </> "tmp.config"-        _ <- createDefaultConfigFile silent configFile+        _ <- createDefaultConfigFile silent [] configFile         exists <- doesFileExist configFile         assertBool ("Config file should be written to " ++ configFile) exists

+ tests/UnitTests/Distribution/Solver/Modular/Builder.hs view

@@ -0,0 +1,20 @@+module UnitTests.Distribution.Solver.Modular.Builder (+  tests+  ) where++import Distribution.Solver.Modular.Builder++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests = [ testProperty "splitsAltImplementation" splitsTest+        ]++-- | Simpler splits implementation+splits' :: [a] -> [(a, [a])]+splits' [] = []+splits' (x : xs) = (x, xs) : map (\ (y, ys) -> (y, x : ys)) (splits' xs)++splitsTest :: [Int] -> Property+splitsTest xs = splits' xs === splits xs

tests/UnitTests/Distribution/Solver/Modular/DSL.hs view

@@ -32,16 +32,15 @@   , withExe   , withExes   , runProgress+  , mkSimpleVersion   , mkVersionRange   ) where  import Prelude ()-import Distribution.Client.Compat.Prelude+import Distribution.Solver.Compat.Prelude  -- base import Data.Either (partitionEithers)-import Data.List (elemIndex)-import Data.Ord (comparing) import qualified Data.Map as Map  -- Cabal@@ -51,6 +50,7 @@ import qualified Distribution.ModuleName                as Module import qualified Distribution.Package                   as C   hiding (HasUnitId(..))+import qualified Distribution.Types.ExeDependency as C import qualified Distribution.Types.LegacyExeDependency as C import qualified Distribution.Types.PkgconfigDependency as C import qualified Distribution.Types.UnqualComponentName as C@@ -149,12 +149,18 @@     -- and an exclusive upper bound.   | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion -    -- | Build-tools dependency-  | ExBuildToolAny ExamplePkgName+    -- | Build-tool-depends dependency+  | ExBuildToolAny ExamplePkgName ExampleExeName -    -- | Build-tools dependency on a fixed version-  | ExBuildToolFix ExamplePkgName ExamplePkgVersion+    -- | Build-tool-depends dependency on a fixed version+  | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion +    -- | Legacy build-tools dependency+  | ExLegacyBuildToolAny ExamplePkgName++    -- | Legacy build-tools dependency on a fixed version+  | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion+     -- | Dependencies indexed by a flag   | ExFlagged ExampleFlagName Dependencies Dependencies @@ -187,10 +193,13 @@ data ExConstraint =     ExVersionConstraint ConstraintScope ExampleVersionRange   | ExFlagConstraint ConstraintScope ExampleFlagName Bool+  | ExStanzaConstraint ConstraintScope [OptionalStanza]+  deriving Show  data ExPreference =     ExPkgPref ExamplePkgName ExampleVersionRange   | ExStanzaPref ExamplePkgName [OptionalStanza]+  deriving Show  data ExampleAvailable = ExAv {     exAvName    :: ExamplePkgName@@ -208,11 +217,18 @@   | S ExampleQualifier ExamplePkgName OptionalStanza  data ExampleQualifier =-    None-  | Indep Int-  | Setup ExamplePkgName-  | IndepSetup Int ExamplePkgName+    QualNone+  | QualIndep ExamplePkgName+  | QualSetup ExamplePkgName +    -- The two package names are the build target and the package containing the+    -- setup script.+  | QualIndepSetup ExamplePkgName ExamplePkgName++    -- The two package names are the package depending on the exe and the+    -- package containing the exe.+  | QualExe ExamplePkgName ExamplePkgName+ -- | Whether to enable tests in all packages in a test case. newtype EnableAllTests = EnableAllTests Bool   deriving BooleanFlag@@ -333,10 +349,10 @@                 C.packageDescription = C.emptyPackageDescription {                     C.package        = pkgId                   , C.setupBuildInfo = setup-                  , C.license = BSD3-                  , C.buildType = if isNothing setup-                                  then Just C.Simple-                                  else Just C.Custom+                  , C.licenseRaw = Right BSD3+                  , C.buildTypeRaw = if isNothing setup+                                     then Just C.Simple+                                     else Just C.Custom                   , C.category = "category"                   , C.maintainer = "maintainer"                   , C.description = "description"@@ -395,37 +411,46 @@                      , [Extension]                      , Maybe Language                      , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config-                     , [(ExamplePkgName, C.VersionRange)] -- build tools+                     , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools+                     , [(ExamplePkgName, C.VersionRange)] -- legacy build tools                      )     splitTopLevel [] =-        ([], [], Nothing, [], [])-    splitTopLevel (ExBuildToolAny p:deps) =-      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps-      in (other, exts, lang, pcpkgs, (p, C.anyVersion):exes)-    splitTopLevel (ExBuildToolFix p v:deps) =-      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps-      in (other, exts, lang, pcpkgs, (p, C.thisVersion (mkVersion v)):exes)+        ([], [], Nothing, [], [], [])+    splitTopLevel (ExBuildToolAny p e:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes)+    splitTopLevel (ExBuildToolFix p e v:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes)+    splitTopLevel (ExLegacyBuildToolAny p:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes)+    splitTopLevel (ExLegacyBuildToolFix p v:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes)     splitTopLevel (ExExt ext:deps) =-      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps-      in (other, ext:exts, lang, pcpkgs, exes)+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, ext:exts, lang, pcpkgs, exes, legacyExes)     splitTopLevel (ExLang lang:deps) =         case splitTopLevel deps of-            (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes)+            (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes)             _ -> error "Only 1 Language dependency is supported"     splitTopLevel (ExPkg pkg:deps) =-      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps-      in (other, exts, lang, pkg:pcpkgs, exes)+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pkg:pcpkgs, exes, legacyExes)     splitTopLevel (dep:deps) =-      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps-      in (dep:other, exts, lang, pcpkgs, exes)+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (dep:other, exts, lang, pcpkgs, exes, legacyExes)      -- Extract the total set of flags used     extractFlags :: ExampleDependency -> [ExampleFlagName]     extractFlags (ExAny _)            = []     extractFlags (ExFix _ _)          = []     extractFlags (ExRange _ _ _)      = []-    extractFlags (ExBuildToolAny _)   = []-    extractFlags (ExBuildToolFix _ _) = []+    extractFlags (ExBuildToolAny _ _)   = []+    extractFlags (ExBuildToolFix _ _ _) = []+    extractFlags (ExLegacyBuildToolAny _)   = []+    extractFlags (ExLegacyBuildToolFix _ _) = []     extractFlags (ExFlagged f a b)    =         f : concatMap extractFlags (deps a ++ deps b)       where@@ -467,17 +492,19 @@            , C.condTreeComponents  = []            }     mkBuildInfoTree (Buildable deps) =-      let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps+      let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel deps           (directDeps, flaggedDeps) = splitDeps libraryDeps           bi = mempty {                   C.otherExtensions = exts                 , C.defaultLanguage = mlang+                , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr+                                       | (p, e, vr) <- buildTools]                 , C.buildTools = [ C.LegacyExeDependency n vr-                                 | (n,vr) <- buildTools ]+                                 | (n,vr) <- legacyBuildTools]                 , C.pkgconfigDepends = [ C.PkgconfigDependency n' v'                                        | (n,v) <- pcpkgs                                        , let n' = C.mkPkgconfigName n-                                       , let v' = C.thisVersion (mkVersion v) ]+                                       , let v' = C.thisVersion (mkSimpleVersion v) ]               }       in C.CondNode {              C.condTreeData        = bi -- Necessary for language extensions@@ -514,7 +541,7 @@       in ((p, C.anyVersion):directDeps, flaggedDeps)     splitDeps (ExFix p v:deps) =       let (directDeps, flaggedDeps) = splitDeps deps-      in ((p, C.thisVersion $ mkVersion v):directDeps, flaggedDeps)+      in ((p, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps)     splitDeps (ExRange p v1 v2:deps) =       let (directDeps, flaggedDeps) = splitDeps deps       in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps)@@ -528,13 +555,13 @@     mkSetupDeps deps =       let (directDeps, []) = splitDeps deps in map mkDirect directDeps -mkVersion :: ExamplePkgVersion -> C.Version-mkVersion n = C.mkVersion [n, 0, 0]+mkSimpleVersion :: ExamplePkgVersion -> C.Version+mkSimpleVersion n = C.mkVersion [n, 0, 0]  mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange mkVersionRange v1 v2 =-    C.intersectVersionRanges (C.orLaterVersion $ mkVersion v1)-                             (C.earlierVersion $ mkVersion v2)+    C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1)+                             (C.earlierVersion $ mkSimpleVersion v2)  mkFlag :: ExFlag -> C.Flag mkFlag flag = C.MkFlag {@@ -587,20 +614,22 @@           -> Maybe [Language]           -> PC.PkgConfigDb           -> [ExamplePkgName]-          -> Solver           -> Maybe Int+          -> CountConflicts           -> IndependentGoals           -> ReorderGoals           -> AllowBootLibInstalls           -> EnableBackjumping-          -> Maybe [ExampleVar]+          -> SolveExecutables+          -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)           -> [ExConstraint]           -> [ExPreference]           -> EnableAllTests           -> Progress String String CI.SolverInstallPlan.SolverInstallPlan-exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder-          allowBootLibInstalls enableBj vars constraints prefs enableAllTests-    = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params+exResolve db exts langs pkgConfigDb targets mbj countConflicts indepGoals+          reorder allowBootLibInstalls enableBj solveExes goalOrder constraints+          prefs enableAllTests+    = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params   where     defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag     compiler = defaultCompiler { C.compilerInfoExtensions = exts@@ -622,11 +651,13 @@     params       =   addConstraints (fmap toConstraint constraints)                    $ addConstraints (fmap toLpc enableTests)                    $ addPreferences (fmap toPref prefs)+                   $ setCountConflicts countConflicts                    $ setIndependentGoals indepGoals                    $ setReorderGoals reorder                    $ setMaxBackjumps mbj                    $ setAllowBootLibInstalls allowBootLibInstalls                    $ setEnableBackjumping enableBj+                   $ setSolveExecutables solveExes                    $ setGoalOrder goalOrder                    $ standardInstallPolicy instIdx avaiIdx targets'     toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown@@ -634,33 +665,12 @@     toConstraint (ExVersionConstraint scope v) =         toLpc $ PackageConstraint scope (PackagePropertyVersion v)     toConstraint (ExFlagConstraint scope fn b) =-        toLpc $ PackageConstraint scope (PackagePropertyFlags [(C.mkFlagName fn, b)])+        toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)]))+    toConstraint (ExStanzaConstraint scope stanzas) =+        toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas)      toPref (ExPkgPref n v)          = PackageVersionPreference (C.mkPackageName n) v     toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas--    goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)-    goalOrder = (orderFromList . map toVariable) `fmap` vars--    -- Sort elements in the list ahead of elements not in the list. Otherwise,-    -- follow the order in the list.-    orderFromList :: Eq a => [a] -> a -> a -> Ordering-    orderFromList xs =-        comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)--    toVariable :: ExampleVar -> Variable P.QPN-    toVariable (P q pn)        = PackageVar (toQPN q pn)-    toVariable (F q pn fn)     = FlagVar    (toQPN q pn) (C.mkFlagName fn)-    toVariable (S q pn stanza) = StanzaVar  (toQPN q pn) stanza--    toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN-    toQPN q pn = P.Q pp (C.mkPackageName pn)-      where-        pp = case q of-               None           -> P.PackagePath P.DefaultNamespace P.QualToplevel-               Indep x        -> P.PackagePath (P.Independent x) P.QualToplevel-               Setup p        -> P.PackagePath P.DefaultNamespace (P.QualSetup (C.mkPackageName p))-               IndepSetup x p -> P.PackagePath (P.Independent x) (P.QualSetup (C.mkPackageName p))  extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan                    -> [(ExamplePkgName, ExamplePkgVersion)]

tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs view

@@ -3,9 +3,11 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils (     SolverTest   , SolverResult(..)+  , maxBackjumps   , independentGoals   , allowBootLibInstalls   , disableBackjumping+  , disableSolveExecutables   , goalOrder   , constraints   , preferences@@ -21,22 +23,33 @@   , runTest   ) where +import Prelude ()+import Distribution.Solver.Compat.Prelude++import Data.List (elemIndex)+import Data.Ord (comparing)+ -- test-framework import Test.Tasty as TF import Test.Tasty.HUnit (testCase, assertEqual, assertBool)  -- Cabal+import qualified Distribution.PackageDescription as C+import qualified Distribution.Types.PackageName as C import Language.Haskell.Extension (Extension(..), Language(..))  -- cabal-install+import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.Variable import Distribution.Client.Dependency (foldProgress)-import Distribution.Client.Dependency.Types-         ( Solver(Modular) ) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Options +maxBackjumps :: Maybe Int -> SolverTest -> SolverTest+maxBackjumps mbj test = test { testMaxBackjumps = mbj }+ -- | Combinator to turn on --independent-goals behavior, i.e. solve -- for the goals as if we were solving for each goal independently. independentGoals :: SolverTest -> SolverTest@@ -50,6 +63,10 @@ disableBackjumping test =     test { testEnableBackjumping = EnableBackjumping False } +disableSolveExecutables :: SolverTest -> SolverTest+disableSolveExecutables test =+    test { testSolveExecutables = SolveExecutables False }+ goalOrder :: [ExampleVar] -> SolverTest -> SolverTest goalOrder order test = test { testGoalOrder = Just order } @@ -67,20 +84,22 @@ -------------------------------------------------------------------------------}  data SolverTest = SolverTest {-    testLabel          :: String-  , testTargets        :: [String]-  , testResult         :: SolverResult-  , testIndepGoals     :: IndependentGoals+    testLabel                :: String+  , testTargets              :: [String]+  , testResult               :: SolverResult+  , testMaxBackjumps         :: Maybe Int+  , testIndepGoals           :: IndependentGoals   , testAllowBootLibInstalls :: AllowBootLibInstalls-  , testEnableBackjumping :: EnableBackjumping-  , testGoalOrder      :: Maybe [ExampleVar]-  , testConstraints    :: [ExConstraint]-  , testSoftConstraints :: [ExPreference]-  , testDb             :: ExampleDb-  , testSupportedExts  :: Maybe [Extension]-  , testSupportedLangs :: Maybe [Language]-  , testPkgConfigDb    :: PkgConfigDb-  , testEnableAllTests :: EnableAllTests+  , testEnableBackjumping    :: EnableBackjumping+  , testSolveExecutables     :: SolveExecutables+  , testGoalOrder            :: Maybe [ExampleVar]+  , testConstraints          :: [ExConstraint]+  , testSoftConstraints      :: [ExPreference]+  , testDb                   :: ExampleDb+  , testSupportedExts        :: Maybe [Extension]+  , testSupportedLangs       :: Maybe [Language]+  , testPkgConfigDb          :: PkgConfigDb+  , testEnableAllTests       :: EnableAllTests   }  -- | Expected result of a solver test.@@ -158,20 +177,22 @@                 -> SolverResult                 -> SolverTest mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {-    testLabel          = label-  , testTargets        = targets-  , testResult         = result-  , testIndepGoals     = IndependentGoals False+    testLabel                = label+  , testTargets              = targets+  , testResult               = result+  , testMaxBackjumps         = Nothing+  , testIndepGoals           = IndependentGoals False   , testAllowBootLibInstalls = AllowBootLibInstalls False-  , testEnableBackjumping = EnableBackjumping True-  , testGoalOrder      = Nothing-  , testConstraints    = []-  , testSoftConstraints = []-  , testDb             = db-  , testSupportedExts  = exts-  , testSupportedLangs = langs-  , testPkgConfigDb    = pkgConfigDbFromList pkgConfigDb-  , testEnableAllTests = EnableAllTests False+  , testEnableBackjumping    = EnableBackjumping True+  , testSolveExecutables     = SolveExecutables True+  , testGoalOrder            = Nothing+  , testConstraints          = []+  , testSoftConstraints      = []+  , testDb                   = db+  , testSupportedExts        = exts+  , testSupportedLangs       = langs+  , testPkgConfigDb          = pkgConfigDbFromList pkgConfigDb+  , testEnableAllTests       = EnableAllTests False   }  runTest :: SolverTest -> TF.TestTree@@ -179,12 +200,12 @@     testCase testLabel $ do       let progress = exResolve testDb testSupportedExts                      testSupportedLangs testPkgConfigDb testTargets-                     Modular Nothing testIndepGoals (ReorderGoals False)-                     testAllowBootLibInstalls testEnableBackjumping testGoalOrder-                     testConstraints testSoftConstraints testEnableAllTests-          printMsg msg = if showSolverLog-                         then putStrLn msg-                         else return ()+                     testMaxBackjumps (CountConflicts True) testIndepGoals+                     (ReorderGoals False) testAllowBootLibInstalls+                     testEnableBackjumping testSolveExecutables+                     (sortGoals <$> testGoalOrder) testConstraints+                     testSoftConstraints testEnableAllTests+          printMsg msg = when showSolverLog $ putStrLn msg           msgs = foldProgress (:) (const []) (const []) progress       assertBool ("Unexpected solver log:\n" ++ unlines msgs) $                  resultLogPredicate testResult $ concatMap lines msgs@@ -202,3 +223,32 @@         case resultErrorMsgPredicateOrPlan result of           Left f  -> f msg           Right _ -> False++    sortGoals :: [ExampleVar]+              -> Variable P.QPN -> Variable P.QPN -> Ordering+    sortGoals = orderFromList . map toVariable++    -- Sort elements in the list ahead of elements not in the list. Otherwise,+    -- follow the order in the list.+    orderFromList :: Eq a => [a] -> a -> a -> Ordering+    orderFromList xs =+        comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)++    toVariable :: ExampleVar -> Variable P.QPN+    toVariable (P q pn)        = PackageVar (toQPN q pn)+    toVariable (F q pn fn)     = FlagVar    (toQPN q pn) (C.mkFlagName fn)+    toVariable (S q pn stanza) = StanzaVar  (toQPN q pn) stanza++    toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN+    toQPN q pn = P.Q pp (C.mkPackageName pn)+      where+        pp = case q of+               QualNone           -> P.PackagePath P.DefaultNamespace P.QualToplevel+               QualIndep p        -> P.PackagePath (P.Independent $ C.mkPackageName p)+                                                   P.QualToplevel+               QualSetup s        -> P.PackagePath P.DefaultNamespace+                                                   (P.QualSetup (C.mkPackageName s))+               QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p)+                                                   (P.QualSetup (C.mkPackageName s))+               QualExe p1 p2      -> P.PackagePath P.DefaultNamespace+                                                   (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))

tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs view

@@ -11,6 +11,8 @@       runTest $ basicTest "basic space leak test"     , runTest $ flagsTest "package with many flags"     , runTest $ issue2899 "issue #2899"+    , runTest $ duplicateDependencies "duplicate dependencies"+    , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies"     ]  -- | This test solves for n packages that each have two versions. There is no@@ -49,17 +51,14 @@      pkgs :: ExampleDb     pkgs = [Right $ exAv "pkg" 1 $-                [exFlagged (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]]+                [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]]                  -- The remaining flags have no effect:-             ++ [exFlagged (flagName i) [] [] | i <- [1..n - 1]]+             ++ [exFlagged (numberedFlag i) [] [] | i <- [1..n - 1]]            ] -    flagName :: Int -> ExampleFlagName-    flagName x = "flag-" ++ show x-     orderedFlags :: [ExampleVar]-    orderedFlags = [F None "pkg" (flagName i) | i <- [1..n]]+    orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1..n]]  -- | Test for a space leak caused by sharing of search trees under packages with -- link choices (issue #2899).@@ -94,4 +93,99 @@     pkgName x = "pkg-" ++ show x      goals :: [ExampleVar]-    goals = [P None "setup-dep", P (Setup "target") "setup-dep"]+    goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"]++-- | Test for an issue related to lifting dependencies out of conditionals when+-- converting a PackageDescription to the solver's internal representation.+--+-- Issue:+-- For each conditional and each package B, the solver combined each dependency+-- on B in the true branch with each dependency on B in the false branch. It+-- added the combined dependencies to the build-depends outside of the+-- conditional. Since dependencies could be lifted out of multiple levels of+-- conditionals, the number of new dependencies could grow exponentially in the+-- number of levels. For example, the following package generated 4 copies of B+-- under flag-2=False, 8 copies under flag-1=False, and 16 copies at the top+-- level:+--+-- if flag(flag-1)+--   build-depends: B, B+-- else+--   if flag(flag-2)+--     build-depends: B, B+--   else+--     if flag(flag-3)+--       build-depends: B, B+--     else+--       build-depends: B, B+--+-- This issue caused the quickcheck tests to start frequently running out of+-- memory after an optimization that pruned unreachable branches (See PR #4929).+-- Each problematic test case contained at least one build-depends field with+-- duplicate dependencies, which was then duplicated under multiple levels of+-- conditionals by the solver's "buildable: False" transformation, when+-- "buildable: False" was under multiple flags. Finally, the branch pruning+-- feature put all build-depends fields in consecutive levels of the condition+-- tree, causing the solver's representation of the package to follow the+-- pattern in the example above.+--+-- Now the solver avoids this issue by combining all dependencies on the same+-- package before lifting them out of conditionals.+--+-- This test case is an expanded version of the example above, with library and+-- build-tool dependencies.+duplicateDependencies :: String -> SolverTest+duplicateDependencies name =+    mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]+  where+    copies, depth :: Int+    copies = 50+    depth = 50++    pkgs :: ExampleDb+    pkgs = [+        Right $ exAv "A" 1 (dependencyTree 1)+      , Right $ exAv "B" 1 [] `withExe` ExExe "exe" []+      ]++    dependencyTree :: Int -> [ExampleDependency]+    dependencyTree n+        | n > depth = buildDepends+        | otherwise = [exFlagged (numberedFlag n) buildDepends+                                                  (dependencyTree (n + 1))]+      where+        buildDepends = replicate copies (ExFix "B" 1)+                    ++ replicate copies (ExBuildToolFix "B" "exe" 1)++-- | This test is similar to duplicateDependencies, except that every dependency+-- on B is replaced by a conditional that contains B in both branches. It tests+-- that the solver doesn't just combine dependencies within one build-depends or+-- build-tool-depends field; it also needs to combine dependencies after they+-- are lifted out of conditionals.+duplicateFlaggedDependencies :: String -> SolverTest+duplicateFlaggedDependencies name =+    mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]+  where+    copies, depth :: Int+    copies = 15+    depth = 15++    pkgs :: ExampleDb+    pkgs = [+        Right $ exAv "A" 1 (dependencyTree 1)+      , Right $ exAv "B" 1 [] `withExe` ExExe "exe" []+      ]++    dependencyTree :: Int -> [ExampleDependency]+    dependencyTree n+        | n > depth = flaggedDeps+        | otherwise = [exFlagged (numberedFlag n) flaggedDeps+                                                  (dependencyTree (n + 1))]+      where+        flaggedDeps = zipWith ($) (replicate copies flaggedDep) [0 :: Int ..]+        flaggedDep m = exFlagged (numberedFlag n ++ "-" ++ show m) buildDepends+                                                                   buildDepends+        buildDepends = [ExFix "B" 1, ExBuildToolFix "B" "exe" 1]++numberedFlag :: Int -> ExampleFlagName+numberedFlag n = "flag-" ++ show n

− tests/UnitTests/Distribution/Solver/Modular/PSQ.hs

@@ -1,22 +0,0 @@-module UnitTests.Distribution.Solver.Modular.PSQ (-  tests-  ) where--import Distribution.Solver.Modular.PSQ--import Test.Tasty-import Test.Tasty.QuickCheck--tests :: [TestTree]-tests = [ testProperty "splitsAltImplementation" splitsTest-        ]---- | Original splits implementation-splits' :: PSQ k a -> PSQ k (a, PSQ k a)-splits' xs =-  casePSQ xs-    (PSQ [])-    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys)))--splitsTest :: [(Int, Int)] -> Bool-splitsTest psq = splits' (PSQ psq) == splits (PSQ psq)

tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs view

@@ -1,41 +1,49 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where -import Control.DeepSeq (NFData, force)-import Control.Monad (foldM)+import Prelude ()+import Distribution.Client.Compat.Prelude++import Control.Arrow ((&&&))+import Control.DeepSeq (force) import Data.Either (lefts) import Data.Function (on)-import Data.List (groupBy, isInfixOf, nub, nubBy, sort)-import Data.Maybe (isJust)-import GHC.Generics (Generic)--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-import Data.Monoid (Monoid)-#endif+import Data.Hashable (Hashable(..))+import Data.List (groupBy, isInfixOf)+import Data.Ord (comparing)  import Text.Show.Pretty (parseValue, valToStr)  import Test.Tasty (TestTree) import Test.Tasty.QuickCheck -import Distribution.Client.Dependency.Types-         ( Solver(..) )+import Distribution.Types.GenericPackageDescription (FlagName)+import Distribution.Utils.ShortText (ShortText)+ import Distribution.Client.Setup (defaultMaxBackjumps) +import           Distribution.Types.PackageName import           Distribution.Types.UnqualComponentName  import qualified Distribution.Solver.Types.ComponentDeps as CD import           Distribution.Solver.Types.ComponentDeps                    ( Component(..), ComponentDep, ComponentDeps )+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackagePath as P import           Distribution.Solver.Types.PkgConfigDb                    (pkgConfigDbFromList) import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.Variable+import           Distribution.Version  import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils+    ( testPropertyWithSeed )  tests :: [TestTree] tests = [@@ -43,12 +51,15 @@       -- existence of a solution. It runs the solver twice, and only sets those       -- parameters on the second run. The test also applies parameters that       -- can affect the existence of a solution to both runs.-      testProperty "target order and --reorder-goals do not affect solvability" $-          \(SolverTest db targets) targetOrder reorderGoals indepGoals solver ->-            let r1 = solve' (ReorderGoals False) targets  db-                r2 = solve' reorderGoals         targets2 db-                solve' reorder = solve (EnableBackjumping True) reorder-                                       indepGoals solver+      testPropertyWithSeed "target and goal order do not affect solvability" $+          \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals ->+            let r1 = solve' mGoalOrder1 test+                r2 = solve' mGoalOrder2 test { testTargets = targets2 }+                solve' goalOrder =+                    solve (EnableBackjumping True) (ReorderGoals False)+                          (CountConflicts True) indepGoals+                          (getBlind <$> goalOrder)+                targets = testTargets test                 targets2 = case targetOrder of                              SameOrder -> targets                              ReverseOrder -> reverse targets@@ -56,25 +67,44 @@                noneReachedBackjumpLimit [r1, r2] ==>                isRight (resultPlan r1) === isRight (resultPlan r2) -    , testProperty+    , testPropertyWithSeed           "solvable without --independent-goals => solvable with --independent-goals" $-          \(SolverTest db targets) reorderGoals solver ->-            let r1 = solve' (IndependentGoals False) targets db-                r2 = solve' (IndependentGoals True)  targets db-                solve' indep = solve (EnableBackjumping True)-                                     reorderGoals indep solver+          \test reorderGoals ->+            let r1 = solve' (IndependentGoals False) test+                r2 = solve' (IndependentGoals True)  test+                solve' indep = solve (EnableBackjumping True) reorderGoals+                                     (CountConflicts True) indep Nothing              in counterexample (showResults r1 r2) $                 noneReachedBackjumpLimit [r1, r2] ==>                 isRight (resultPlan r1) `implies` isRight (resultPlan r2) -    , testProperty "backjumping does not affect solvability" $-          \(SolverTest db targets) reorderGoals indepGoals ->-            let r1 = solve' (EnableBackjumping True)  targets db-                r2 = solve' (EnableBackjumping False) targets db-                solve' enableBj = solve enableBj reorderGoals indepGoals Modular+    , testPropertyWithSeed "backjumping does not affect solvability" $+          \test reorderGoals indepGoals ->+            let r1 = solve' (EnableBackjumping True)  test+                r2 = solve' (EnableBackjumping False) test+                solve' enableBj = solve enableBj reorderGoals+                                        (CountConflicts True) indepGoals Nothing              in counterexample (showResults r1 r2) $                 noneReachedBackjumpLimit [r1, r2] ==>                 isRight (resultPlan r1) === isRight (resultPlan r2)++    -- This test uses --no-count-conflicts, because the goal order used with+    -- --count-conflicts depends on the total set of conflicts seen by the+    -- solver. The solver explores more of the tree and encounters more+    -- conflicts when it doesn't backjump. The different goal orders can lead to+    -- different solutions and cause the test to fail.+    -- TODO: Find a faster way to randomly sort goals, and then use a random+    -- goal order in this test.+    , testPropertyWithSeed+          "backjumping does not affect the result (with static goal order)" $+          \test reorderGoals indepGoals ->+            let r1 = solve' (EnableBackjumping True)  test+                r2 = solve' (EnableBackjumping False) test+                solve' enableBj = solve enableBj reorderGoals+                                  (CountConflicts False) indepGoals Nothing+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                resultPlan r1 === resultPlan r2     ]   where     noneReachedBackjumpLimit :: [Result] -> Bool@@ -97,19 +127,25 @@     isRight (Right _) = True     isRight _         = False -solve :: EnableBackjumping -> ReorderGoals -> IndependentGoals-      -> Solver -> [PN] -> TestDb -> Result-solve enableBj reorder indep solver targets (TestDb db) =+newtype VarOrdering = VarOrdering {+      unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering+    }++solve :: EnableBackjumping -> ReorderGoals -> CountConflicts -> IndependentGoals+      -> Maybe VarOrdering+      -> SolverTest -> Result+solve enableBj reorder countConflicts indep goalOrder test =   let (lg, result) =-        runProgress $ exResolve db Nothing Nothing+        runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing                   (pkgConfigDbFromList [])-                  (map unPN targets)-                  solver+                  (map unPN (testTargets test))                   -- The backjump limit prevents individual tests from using                   -- too much time and memory.                   (Just defaultMaxBackjumps)-                  indep reorder (AllowBootLibInstalls False) enableBj Nothing [] []-                  (EnableAllTests True)+                  countConflicts indep reorder (AllowBootLibInstalls False)+                  enableBj (SolveExecutables True) (unVarOrdering <$> goalOrder)+                  (testConstraints test) (testPreferences test)+                  (EnableAllTests False)        failure :: String -> Failure       failure msg@@ -168,26 +204,40 @@ data SolverTest = SolverTest {     testDb :: TestDb   , testTargets :: [PN]+  , testConstraints :: [ExConstraint]+  , testPreferences :: [ExPreference]   }  -- | Pretty-print the test when quickcheck calls 'show'. instance Show SolverTest where   show test =     let str = "SolverTest {testDb = " ++ show (testDb test)-                     ++ ", testTargets = " ++ show (testTargets test) ++ "}"+                     ++ ", testTargets = " ++ show (testTargets test)+                     ++ ", testConstraints = " ++ show (testConstraints test)+                     ++ ", testPreferences = " ++ show (testPreferences test)+                     ++ "}"     in maybe str valToStr $ parseValue str  instance Arbitrary SolverTest where   arbitrary = do     db <- arbitrary-    let pkgs = nub $ map getName (unTestDb db)+    let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db)+        pkgs = nub $ map fst pkgVersions     Positive n <- arbitrary     targets <- randomSubset n pkgs-    return (SolverTest db targets)+    constraints <- case pkgVersions of+                     [] -> return []+                     _  -> boundedListOf 1 $ arbitraryConstraint pkgVersions+    prefs <- case pkgVersions of+               [] -> return []+               _  -> boundedListOf 3 $ arbitraryPreference pkgVersions+    return (SolverTest db targets constraints prefs)    shrink test =          [test { testDb = db } | db <- shrink (testDb test)]       ++ [test { testTargets = targets } | targets <- shrink (testTargets test)]+      ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)]+      ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)]  -- | Collection of source and installed packages. newtype TestDb = TestDb { unTestDb :: ExampleDb }@@ -203,7 +253,7 @@       TestDb <$> shuffle (unTestDb db)     where       nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb-      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs+      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs        nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage       nextPkg db (pn, v) = do@@ -220,10 +270,10 @@  arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled arbitraryExInst pn v pkgs = do-  hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']+  pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']   numDeps <- min 3 <$> arbitrary   deps <- randomSubset numDeps pkgs-  return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps)+  return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps)  arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency]) arbitraryComponentDeps (TestDb []) = return $ CD.fromList []@@ -288,6 +338,34 @@ arbitraryFlagName :: Gen String arbitraryFlagName = (:[]) <$> elements ['A'..'E'] +arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint+arbitraryConstraint pkgs = do+  (PN pn, v) <- elements pkgs+  let anyQualifier = ScopeAnyQualifier (mkPackageName pn)+  oneof [+      ExVersionConstraint anyQualifier <$> arbitraryVersionRange v+    , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas]+    ]++arbitraryPreference :: [(PN, PV)] -> Gen ExPreference+arbitraryPreference pkgs = do+  (PN pn, v) <- elements pkgs+  oneof [+      ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas]+    , ExPkgPref pn <$> arbitraryVersionRange v+    ]++arbitraryVersionRange :: PV -> Gen VersionRange+arbitraryVersionRange (PV v) =+  let version = mkSimpleVersion v+  in elements [+         thisVersion version+       , notThisVersion version+       , earlierVersion version+       , orLaterVersion version+       , noVersion+       ]+ instance Arbitrary ReorderGoals where   arbitrary = ReorderGoals <$> arbitrary @@ -298,11 +376,6 @@    shrink (IndependentGoals indep) = [IndependentGoals False | indep] -instance Arbitrary Solver where-  arbitrary = return Modular--  shrink Modular = []- instance Arbitrary UnqualComponentName where   arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC" @@ -355,6 +428,56 @@    shrink NotBuildable = [Buildable []]   shrink (Buildable deps) = map Buildable (shrink deps)++instance Arbitrary ExConstraint where+  arbitrary = error "arbitrary not implemented: ExConstraint"++  shrink (ExStanzaConstraint scope stanzas) =+      [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas]+  shrink (ExVersionConstraint scope vr) =+      [ExVersionConstraint scope vr' | vr' <- shrink vr]+  shrink _ = []++instance Arbitrary ExPreference where+  arbitrary = error "arbitrary not implemented: ExPreference"++  shrink (ExStanzaPref pn stanzas) =+      [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas]+  shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr]++instance Arbitrary OptionalStanza where+  arbitrary = error "arbitrary not implemented: OptionalStanza"++  shrink BenchStanzas = [TestStanzas]+  shrink TestStanzas  = []++instance Arbitrary VersionRange where+  arbitrary = error "arbitrary not implemented: VersionRange"++  shrink vr = [noVersion | vr /= noVersion]++-- Randomly sorts solver variables using 'hash'.+-- TODO: Sorting goals with this function is very slow.+instance Arbitrary VarOrdering where+  arbitrary = do+      f <- arbitrary :: Gen (Int -> Int)+      return $ VarOrdering (comparing (f . hash))++instance Hashable pn => Hashable (Variable pn)+instance Hashable a => Hashable (P.Qualified a)+instance Hashable P.PackagePath+instance Hashable P.Qualifier+instance Hashable P.Namespace+instance Hashable OptionalStanza+instance Hashable FlagName+instance Hashable PackageName+instance Hashable ShortText++deriving instance Generic (Variable pn)+deriving instance Generic (P.Qualified a)+deriving instance Generic P.PackagePath+deriving instance Generic P.Namespace+deriving instance Generic P.Qualifier  randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs

+ tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs view

@@ -0,0 +1,33 @@+module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils (+    testPropertyWithSeed+  ) where++import Data.Tagged (Tagged, retag)+import System.Random (getStdRandom, random)++import Test.Tasty (TestTree)+import Test.Tasty.Options (OptionDescription, lookupOption, setOption)+import Test.Tasty.Providers (IsTest (..), singleTest)+import Test.Tasty.QuickCheck+    ( QC (..), QuickCheckReplay (..), Testable, property )++import Distribution.Simple.Utils+import Distribution.Verbosity++-- | Create a QuickCheck test that prints the seed before testing the property.+-- The seed can be useful for debugging non-terminating test cases. This is+-- related to https://github.com/feuerbach/tasty/issues/86.+testPropertyWithSeed :: Testable a => String -> a -> TestTree+testPropertyWithSeed name = singleTest name . QCWithSeed . QC . property++newtype QCWithSeed = QCWithSeed QC++instance IsTest QCWithSeed where+  testOptions = retag (testOptions :: Tagged QC [OptionDescription])++  run options (QCWithSeed test) progress = do+    replay <- case lookupOption options of+                 QuickCheckReplay (Just override) -> return override+                 QuickCheckReplay Nothing         -> getStdRandom random+    notice normal $ "Using --quickcheck-replay=" ++ show replay+    run (setOption (QuickCheckReplay (Just replay)) options) test progress

tests/UnitTests/Distribution/Solver/Modular/Solver.hs view

@@ -21,7 +21,7 @@ import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackagePath+import qualified Distribution.Solver.Types.PackagePath as P import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils @@ -51,12 +51,17 @@         , runTest $ indep $ mkTest db4 "linkFlags2"   ["C", "D"] anySolverFailure         , runTest $ indep $ mkTest db18 "linkFlags3"  ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])         ]+    , testGroup "Lifting dependencies out of conditionals" [+          runTest $ commonDependencyLogMessage "common dependency log message"+        , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message"+        , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency"+        ]     , testGroup "Manual flags" [           runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $           solverSuccess [("pkg", 1), ("true-dep", 1)]          , let checkFullLog =-                  any $ isInfixOf "rejecting: pkg-1.0.0:-flag (manual flag can only be changed explicitly)"+                  any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)"           in runTest $ constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $              mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $              -- TODO: We should check the summarized log instead of the full log@@ -71,39 +76,39 @@         ]     , testGroup "Qualified manual flag constraints" [           let name = "Top-level flag constraint does not constrain setup dep's flag"-              cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False]+              cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]           in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $              solverSuccess [ ("A", 1), ("B", 1), ("B", 2)                            , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ]          , let name = "Solver can toggle setup dep's flag to match top-level constraint"-              cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False+              cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False                    , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ]           in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $              solverSuccess [ ("A", 1), ("B", 1), ("B", 2)                            , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ]          , let name = "User can constrain flags separately with qualified constraints"-              cs = [ ExFlagConstraint (ScopeQualified QualToplevel    "B") "flag" True-                   , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ]+              cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel    "B") "flag" True+                   , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]           in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $              solverSuccess [ ("A", 1), ("B", 1), ("B", 2)                            , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ]            -- Regression test for #4299         , let name = "Solver can link deps when only one has constrained manual flag"-              cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False]+              cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]           in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $              solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ]          , let name = "Solver cannot link deps that have conflicting manual flag constraints"-              cs = [ ExFlagConstraint (ScopeQualified QualToplevel    "B") "flag" True-                   , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ]+              cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel    "B") "flag" True+                   , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]               failureReason = "(constraint from unknown source requires opposite flag selection)"               checkFullLog lns =                   all (\msg -> any (msg `isInfixOf`) lns)-                  [ "rejecting: B-1.0.0:-flag "         ++ failureReason-                  , "rejecting: A:setup.B-1.0.0:+flag " ++ failureReason ]+                  [ "rejecting: B:-flag "         ++ failureReason+                  , "rejecting: A:setup.B:+flag " ++ failureReason ]           in runTest $ constraints cs $              mkTest dbLinkedSetupDepWithManualFlag name ["A"] $              SolverResult checkFullLog (Left $ const True)@@ -118,6 +123,7 @@         , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])         , runTest $         enableAllTests $ mkTest db6 "depsWithTests1" ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])         , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])+        , runTest $ testTestSuiteWithFlag "test suite with flag"         ]     , testGroup "Setup dependencies" [           runTest $         mkTest db7  "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)])@@ -153,6 +159,7 @@         , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (solverSuccess [("C", 2), ("D", 1)])         , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (solverSuccess [("D", 1)])         , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (solverSuccess [("C", 2), ("D", 1), ("E", 1)])+        , runTest $ issue4161 "detect cycle between package and its setup script"         , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages"         ]     , testGroup "Extensions" [@@ -179,8 +186,8 @@              mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $              solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] -        , let cs = [ ExVersionConstraint (ScopeQualified QualToplevel    "D") $ mkVersionRange 1 4-                   , ExVersionConstraint (ScopeQualified (QualSetup "B") "D") $ mkVersionRange 4 7+        , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel    "D") $ mkVersionRange 1 4+                   , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7                    ]           in runTest $ constraints cs $              mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $@@ -215,6 +222,8 @@         , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $           mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $           solverSuccess [("pkg", 1)]++        , testStanzaPreference "test stanza preference"         ]      , testGroup "Buildable Field" [           testBuildable "avoid building component with unknown dependency" (ExAny "unknown")@@ -252,15 +261,74 @@         , runTest $         mkTest dbBJ7  "bj7"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])         , runTest $ indep $ mkTest dbBJ8  "bj8"  ["A", "B"] (solverSuccess [("A", 1), ("B",  1), ("C", 1)])         ]-    -- Build-tools dependencies-    , testGroup "build-tools" [-          runTest $ mkTest dbBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)])-        , runTest $ mkTest dbBuildTools2 "bt2" ["A"] (solverSuccess [("A", 1)])-        , runTest $ mkTest dbBuildTools3 "bt3" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)])-        , runTest $ mkTest dbBuildTools4 "bt4" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)])-        , runTest $ mkTest dbBuildTools5 "bt5" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)])-        , runTest $ mkTest dbBuildTools6 "bt6" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)])+    -- build-tool-depends dependencies+    , testGroup "build-tool-depends" [+          runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)])++        , runTest $ disableSolveExecutables $+          mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)])++        , runTest $ enableAllTests $+          mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)])++        , runTest $ mkTest dbBuildTools "unknown exe" ["D"] $+          solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by D")++        , runTest $ disableSolveExecutables $+          mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ solverSuccess [("D", 1)]++        , runTest $ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $+          solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)")++        , runTest $ mkTest dbBuildTools "unknown flagged exe" ["F"] $+          solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by F +flagF")++        , runTest $ enableAllTests $ mkTest dbBuildTools "unknown test suite exe" ["G"] $+          solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by G *test")++        , runTest $ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $+          solverFailure $ isInfixOf $+              -- The solver reports the version conflict when a version conflict+              -- and an executable conflict apply to the same package version.+              "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n"+           ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable exe1, which is required by H)\n"+           ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0, H:bt-pkg:exe.bt-pkg-1.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)"++        , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success"++        , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure"++        , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency"++        , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package"+    ]+    -- build-tools dependencies+    , testGroup "legacy build-tools" [+          runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)])++        , runTest $ disableSolveExecutables $+          mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbLegacyBuildTools2 "bt2" ["A"] $+          solverFailure (isInfixOf "does not contain executable alex, which is required by A")++        , runTest $ disableSolveExecutables $+          mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)])++        , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)])++        , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)])         ]+      -- internal dependencies+    , testGroup "internal dependencies" [+          runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)])+        ]       -- Tests for the contents of the solver's log     , testGroup "Solver log" [           -- See issue #3203. The solver should only choose a version for A once.@@ -278,6 +346,25 @@                      ++ "these were the goals I've had most trouble fulfilling: A, B"               in mkTest db "exhaustive search failure message" ["A"] $                  solverFailure (isInfixOf msg)+        , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $+                "Could not resolve dependencies:\n"+             ++ "[__0] trying: A-1.0.0 (user goal)\n"+             ++ "[__1] unknown package: D (dependency of A)\n"+             ++ "[__1] fail (backjumping, conflict set: A, D)\n"+             ++ "After searching the rest of the dependency tree exhaustively, "+             ++ "these were the goals I've had most trouble fulfilling: A, D"+        , testSummarizedLog "show first conflicts after inexhaustive search" (Just 2) $+                "Could not resolve dependencies:\n"+             ++ "[__0] trying: A-1.0.0 (user goal)\n"+             ++ "[__1] trying: B-3.0.0 (dependency of A)\n"+             ++ "[__2] next goal: C (dependency of B)\n"+             ++ "[__2] rejecting: C-1.0.0 (conflict: B => C==3.0.0)\n"+             ++ "Backjump limit reached (currently 2, change with --max-backjumps "+             ++ "or try to run with --reorder-goals).\n"+        , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $+                "Backjump limit reached (currently 1, change with --max-backjumps "+             ++ "or try to run with --reorder-goals).\n"+             ++ "Failed to generate a summarized dependency solver log due to low backjump limit."         ]     ]   where@@ -456,6 +543,35 @@   , Right $ exAv "D" 1 [ExAny "B"]   ] +-- | This test checks that the solver can backjump to disable a flag, even if+-- the problematic dependency is also under a test suite. (issue #4390)+--+-- The goal order forces the solver to choose the flag before enabling testing.+-- Previously, the solver couldn't handle this case, because it only tried to+-- disable testing, and when that failed, it backjumped past the flag choice.+-- The solver should also try to set the flag to false, because that avoids the+-- dependency on B.+testTestSuiteWithFlag :: String -> SolverTest+testTestSuiteWithFlag name =+    goalOrder goals $ enableAllTests $ mkTest db name ["A", "B"] $+    solverSuccess [("A", 1), ("B", 1)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 []+          `withTest`+            ExTest "test" [exFlagged "flag" [ExFix "B" 2] []]+      , Right $ exAv "B" 1 []+      ]++    goals :: [ExampleVar]+    goals = [+        P QualNone "B"+      , P QualNone "A"+      , F QualNone "A" "flag"+      , S QualNone "A" TestStanzas+      ]+ -- Packages with setup dependencies -- -- Install..@@ -624,6 +740,32 @@     Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"]   ] +-- | This is a test case for a bug in stanza preferences (#3930). The solver+-- should be able to install 'A' by enabling 'flag' and disabling testing. When+-- it tries goals in the specified order and prefers testing, it encounters+-- 'unknown-pkg2'. 'unknown-pkg2' is only introduced by testing and 'flag', so+-- the conflict set should contain both of those variables. Before the fix, it+-- only contained 'flag'. The solver backjumped past the choice to disable+-- testing and failed to find the solution.+testStanzaPreference :: String -> TestTree+testStanzaPreference name =+  let pkg = exAv "A" 1    [exFlagged "flag"+                              []+                              [ExAny "unknown-pkg1"]]+             `withTest`+            ExTest "test" [exFlagged "flag"+                              [ExAny "unknown-pkg2"]+                              []]+      goals = [+          P QualNone "A"+        , F QualNone "A" "flag"+        , S QualNone "A" TestStanzas+        ]+  in runTest $ goalOrder goals $+     preferences [ ExStanzaPref "A" [TestStanzas]] $+     mkTest [Right pkg] name ["A"] $+     solverSuccess [("A", 1)]+ -- | Database with some cycles -- -- * Simplest non-trivial cycle: A -> B and B -> A@@ -661,6 +803,30 @@   , Right $ exAv   "E" 1            [ExFix "C" 2]   ] +-- | Detect a cycle between a package and its setup script.+--+-- This type of cycle can easily occur when new-build adds default setup+-- dependencies to packages without custom-setup stanzas. For example, cabal+-- adds 'time' as a setup dependency for 'time'. The solver should detect the+-- cycle when it attempts to link the setup and non-setup instances of the+-- package and then choose a different version for the setup dependency.+issue4161 :: String -> SolverTest+issue4161 name =+    mkTest db name ["target"] $+    SolverResult checkFullLog $ Right [("target", 1), ("time", 1), ("time", 2)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "target" 1 [ExFix "time" 2]+      , Right $ exAv "time"   2 []               `withSetupDeps` [ExAny "time"]+      , Right $ exAv "time"   1 []+      ]++    checkFullLog :: [String] -> Bool+    checkFullLog = any $ isInfixOf $+        "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; "+                ++ "conflict set: time:setup.time)"+ -- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack -- as soon as it chooses the last package in the cycle, to avoid searching parts -- of the tree that have no solution. Since there is no way to break the cycle,@@ -692,7 +858,7 @@      -- Solve for pkg-D and pkg-E last.     goals :: [ExampleVar]-    goals = [P None ("pkg-" ++ [c]) | c <- ['A'..'E']]+    goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']]  -- | Check that the solver can backtrack after encountering the SIR (issue #2843) --@@ -752,14 +918,14 @@      goals :: [ExampleVar]     goals = [-        P (Indep 0) "A"-      , P (Indep 0) "C"-      , P (Indep 0) "D"-      , P (Indep 1) "B"-      , P (Indep 1) "C"-      , P (Indep 1) "D"-      , S (Indep 1) "B" TestStanzas-      , S (Indep 0) "A" TestStanzas+        P (QualIndep "A") "A"+      , P (QualIndep "A") "C"+      , P (QualIndep "A") "D"+      , P (QualIndep "B") "B"+      , P (QualIndep "B") "C"+      , P (QualIndep "B") "D"+      , S (QualIndep "B") "B" TestStanzas+      , S (QualIndep "A") "A" TestStanzas       ]  -- | Issue #2834@@ -794,6 +960,61 @@   , Right $ exAv "G" 1 []   ] +-- | When both values for flagA introduce package B, the solver should be able+-- to choose B before choosing a value for flagA. It should try to choose a+-- version for B that is in the union of the version ranges required by +flagA+-- and -flagA.+commonDependencyLogMessage :: String -> SolverTest+commonDependencyLogMessage name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+        "[__0] trying: A-1.0.0 (user goal)\n"+     ++ "[__1] next goal: B (dependency of A +/-flagA)\n"+     ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [exFlagged "flagA"+                               [ExFix "B" 1]+                               [ExFix "B" 3]]+      , Right $ exAv "B" 2 []+      ]++-- | Test lifting dependencies out of multiple levels of conditionals.+twoLevelDeepCommonDependencyLogMessage :: String -> SolverTest+twoLevelDeepCommonDependencyLogMessage name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+        "unknown package: B (dependency of A +/-flagA +/-flagB)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [exFlagged "flagA"+                               [exFlagged "flagB"+                                   [ExAny "B"]+                                   [ExAny "B"]]+                               [exFlagged "flagB"+                                   [ExAny "B"]+                                   [ExAny "B"]]]+      ]++-- | Test handling nested conditionals that are controlled by the same flag.+-- The solver should treat flagA as introducing 'unknown' with value true, not+-- both true and false. That means that when +flagA causes a conflict, the+-- solver should try flipping flagA to false to resolve the conflict, rather+-- than backjumping past flagA.+testBackjumpingWithCommonDependency :: String -> SolverTest+testBackjumpingWithCommonDependency name =+    mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [exFlagged "flagA"+                               [exFlagged "flagA"+                                   [ExAny "unknown"]+                                   [ExAny "unknown"]]+                               [ExAny "B"]]+      , Right $ exAv "B" 1 []+      ]+ -- | Tricky test case with independent goals (issue #2842) -- -- Suppose we are installing D, E, and F as independent goals:@@ -836,16 +1057,16 @@      goals :: [ExampleVar]     goals = [-        P (Indep 0) "D"-      , P (Indep 0) "C"-      , P (Indep 0) "A"-      , P (Indep 1) "E"-      , P (Indep 1) "C"-      , P (Indep 1) "B"-      , P (Indep 2) "F"-      , P (Indep 2) "B"-      , P (Indep 2) "C"-      , P (Indep 2) "A"+        P (QualIndep "D") "D"+      , P (QualIndep "D") "C"+      , P (QualIndep "D") "A"+      , P (QualIndep "E") "E"+      , P (QualIndep "E") "C"+      , P (QualIndep "E") "B"+      , P (QualIndep "F") "F"+      , P (QualIndep "F") "B"+      , P (QualIndep "F") "C"+      , P (QualIndep "F") "A"       ]  -- | This test checks that the solver correctly backjumps when dependencies@@ -878,15 +1099,15 @@      goals :: [ExampleVar]     goals = [-        P (Indep 0) "A"-      , P (Indep 0) "E"-      , P (Indep 1) "B"-      , P (Indep 1) "D"-      , P (Indep 1) "E"-      , P (Indep 2) "C"-      , P (Indep 2) "D"-      , P (Indep 2) "E"-      , S (Indep 2) "C" TestStanzas+        P (QualIndep "A") "A"+      , P (QualIndep "A") "E"+      , P (QualIndep "B") "B"+      , P (QualIndep "B") "D"+      , P (QualIndep "B") "E"+      , P (QualIndep "C") "C"+      , P (QualIndep "C") "D"+      , P (QualIndep "C") "E"+      , S (QualIndep "C") "C" TestStanzas       ]  -- | Test the trace messages that we get when a package refers to an unknown pkg@@ -955,14 +1176,14 @@      goals :: [ExampleVar]     goals = [-        P (Indep 0) "X"-      , P (Indep 0) "A"-      , P (Indep 0) "B"-      , P (Indep 0) "C"-      , P (Indep 1) "Y"-      , P (Indep 1) "A"-      , P (Indep 1) "B"-      , P (Indep 1) "C"+        P (QualIndep "X") "X"+      , P (QualIndep "X") "A"+      , P (QualIndep "X") "B"+      , P (QualIndep "X") "C"+      , P (QualIndep "Y") "Y"+      , P (QualIndep "Y") "A"+      , P (QualIndep "Y") "B"+      , P (QualIndep "Y") "C"       ]  -- | A simplified version of 'testIndepGoals5'.@@ -989,12 +1210,12 @@      goals :: [ExampleVar]     goals = [-        P (Indep 0) "X"-      , P (Indep 0) "A"-      , P (Indep 0) "B"-      , P (Indep 1) "Y"-      , P (Indep 1) "A"-      , P (Indep 1) "B"+        P (QualIndep "X") "X"+      , P (QualIndep "X") "A"+      , P (QualIndep "X") "B"+      , P (QualIndep "Y") "Y"+      , P (QualIndep "Y") "A"+      , P (QualIndep "Y") "B"       ]  dbExts1 :: ExampleDb@@ -1080,6 +1301,29 @@   , Right $ exAv "C" 1 [ExAny "B"]   ] +-- | Test for the solver's summarized log. The final conflict set is {A, D},+-- though the goal order forces the solver to find the (avoidable) conflict+-- between B >= 2 and C first. When the solver reaches the backjump limit, it+-- should only show the log to the first conflict. When the backjump limit is+-- high enough to allow an exhaustive search, the solver should make use of the+-- final conflict set to only show the conflict between A and D in the+-- summarized log.+testSummarizedLog :: String -> Maybe Int -> String -> TestTree+testSummarizedLog testName mbj expectedMsg =+    runTest $ maxBackjumps mbj $ goalOrder goals $ mkTest db testName ["A"] $+    solverFailure (== expectedMsg)+  where+    db = [+        Right $ exAv "A" 1 [ExAny "B", ExAny "D"]+      , Right $ exAv "B" 3 [ExFix "C" 3]+      , Right $ exAv "B" 2 [ExFix "C" 2]+      , Right $ exAv "B" 1 [ExAny "C"]+      , Right $ exAv "C" 1 []+      ]++    goals :: [ExampleVar]+    goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]+ {-------------------------------------------------------------------------------   Simple databases for the illustrations for the backjumping blog post -------------------------------------------------------------------------------}@@ -1177,52 +1421,155 @@   ]  {--------------------------------------------------------------------------------  Databases for build-tools+  Databases for build-tool-depends -------------------------------------------------------------------------------}-dbBuildTools1 :: ExampleDb-dbBuildTools1 = [-    Right $ exAv "alex" 1 [],-    Right $ exAv "A" 1 [ExBuildToolAny "alex"]++-- | Multiple packages depending on exes from 'bt-pkg'.+dbBuildTools :: ExampleDb+dbBuildTools = [+    Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"]+  , Right $ exAv "B" 1 [exFlagged "flagB" [ExAny "unknown"]+                                          [ExBuildToolAny "bt-pkg" "exe1"]]+  , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExBuildToolAny "bt-pkg" "exe1"]+  , Right $ exAv "D" 1 [ExBuildToolAny "bt-pkg" "unknown-exe"]+  , Right $ exAv "E" 1 [ExBuildToolAny "unknown-pkg" "exe1"]+  , Right $ exAv "F" 1 [exFlagged "flagF" [ExBuildToolAny "bt-pkg" "unknown-exe"]+                                          [ExAny "unknown"]]+  , Right $ exAv "G" 1 [] `withTest` ExTest "testG" [ExBuildToolAny "bt-pkg" "unknown-exe"]+  , Right $ exAv "H" 1 [ExBuildToolFix "bt-pkg" "exe1" 3]++  , Right $ exAv "bt-pkg" 4 []+  , Right $ exAv "bt-pkg" 3 [] `withExe` ExExe "exe2" []+  , Right $ exAv "bt-pkg" 2 [] `withExe` ExExe "exe1" []+  , Right $ exAv "bt-pkg" 1 []   ] +-- The solver should never choose an installed package for a build tool+-- dependency.+rejectInstalledBuildToolPackage :: String -> SolverTest+rejectInstalledBuildToolPackage name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+    "rejecting: A:B:exe.B-1.0.0/installed-1 "+     ++ "(does not contain executable exe, which is required by A)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"]+      , Left $ exInst "B" 1 "B-1" []+      ]++-- | This test forces the solver to choose B as a build-tool dependency before+-- it sees the dependency on executable exe2 from B. The solver needs to check+-- that the version that it already chose for B contains the necessary+-- executable. This order causes a different "missing executable" error message+-- than when the solver checks for the executable in the same step that it+-- chooses the build-tool package.+--+-- This case may become impossible if we ever add the executable name to the+-- build-tool goal qualifier. Then this test would involve two qualified goals+-- for B, one for exe1 and another for exe2.+chooseExeAfterBuildToolsPackage :: Bool -> String -> SolverTest+chooseExeAfterBuildToolsPackage shouldSucceed name =+    goalOrder goals $ mkTest db name ["A"] $+      if shouldSucceed+      then solverSuccess [("A", 1), ("B", 1)]+      else solverFailure $ isInfixOf $+           "rejecting: A:+flagA (requires executable exe2 from A:B:exe.B, "+            ++ "but the executable does not exist)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ ExBuildToolAny "B" "exe1"+                           , exFlagged "flagA" [ExBuildToolAny "B" "exe2"]+                                               [ExAny "unknown"]]+      , Right $ exAv "B" 1 []+         `withExes`+           [ExExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]]+      ]++    goals :: [ExampleVar]+    goals = [+        P QualNone "A"+      , P (QualExe "A" "B") "B"+      , F QualNone "A" "flagA"+      ]++-- | Test that when one package depends on two executables from another package,+-- both executables must come from the same instance of that package. We could+-- lift this restriction in the future by adding the executable name to the goal+-- qualifier.+requireConsistentBuildToolVersions :: String -> SolverTest+requireConsistentBuildToolVersions name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+        "[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n"+     ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ ExBuildToolFix "B" "exe1" 1+                           , ExBuildToolFix "B" "exe2" 2 ]+      , Right $ exAv "B" 2 [] `withExes` exes+      , Right $ exAv "B" 1 [] `withExes` exes+      ]++    exes = [ExExe "exe1" [], ExExe "exe2" []]++{-------------------------------------------------------------------------------+  Databases for legacy build-tools+-------------------------------------------------------------------------------}+dbLegacyBuildTools1 :: ExampleDb+dbLegacyBuildTools1 = [+    Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]+  ]++-- Test that a recognized build tool dependency specifies the name of both the+-- package and the executable. This db has no solution.+dbLegacyBuildTools2 :: ExampleDb+dbLegacyBuildTools2 = [+    Right $ exAv "alex" 1 [] `withExe` ExExe "other-exe" [],+    Right $ exAv "other-package" 1 [] `withExe` ExExe "alex" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]+  ]+ -- Test that build-tools on a random thing doesn't matter (only -- the ones we recognize need to be in db)-dbBuildTools2 :: ExampleDb-dbBuildTools2 = [-    Right $ exAv "A" 1 [ExBuildToolAny "otherdude"]+dbLegacyBuildTools3 :: ExampleDb+dbLegacyBuildTools3 = [+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"]   ]  -- Test that we can solve for different versions of executables-dbBuildTools3 :: ExampleDb-dbBuildTools3 = [-    Right $ exAv "alex" 1 [],-    Right $ exAv "alex" 2 [],-    Right $ exAv "A" 1 [ExBuildToolFix "alex" 1],-    Right $ exAv "B" 1 [ExBuildToolFix "alex" 2],+dbLegacyBuildTools4 :: ExampleDb+dbLegacyBuildTools4 = [+    Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],+    Right $ exAv "alex" 2 [] `withExe` ExExe "alex" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1],+    Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2],     Right $ exAv "C" 1 [ExAny "A", ExAny "B"]   ]  -- Test that exe is not related to library choices-dbBuildTools4 :: ExampleDb-dbBuildTools4 = [-    Right $ exAv "alex" 1 [ExFix "A" 1],+dbLegacyBuildTools5 :: ExampleDb+dbLegacyBuildTools5 = [+    Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` ExExe "alex" [],     Right $ exAv "A" 1 [],     Right $ exAv "A" 2 [],-    Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2]+    Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2]   ]  -- Test that build-tools on build-tools works-dbBuildTools5 :: ExampleDb-dbBuildTools5 = [-    Right $ exAv "alex" 1 [],-    Right $ exAv "happy" 1 [ExBuildToolAny "alex"],-    Right $ exAv "A" 1 [ExBuildToolAny "happy"]+dbLegacyBuildTools6 :: ExampleDb+dbLegacyBuildTools6 = [+    Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],+    Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` ExExe "happy" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"]   ]  -- Test that build-depends on library/executable package works. -- Extracted from https://github.com/haskell/cabal/issues/3775-dbBuildTools6 :: ExampleDb-dbBuildTools6 = [+dbIssue3775 :: ExampleDb+dbIssue3775 = [     Right $ exAv "warp" 1 [],     -- NB: the warp build-depends refers to the package, not the internal     -- executable!