cabal-install 0.10.2 → 0.14.0

raw patch · 56 files changed

+5158/−1259 lines, 56 filesdep +mtldep ~Cabaldep ~arraydep ~filepathnew-uploader

Dependencies added: mtl

Dependency ranges changed: Cabal, array, filepath, old-time, pretty, process, time, unix

Files

Distribution/Client/BuildReports/Anonymous.hs +8/−4
Distribution/Client/BuildReports/Storage.hs +4/−4
Distribution/Client/BuildReports/Types.hs +1/−1
Distribution/Client/BuildReports/Upload.hs +1/−3
Distribution/Client/Config.hs +39/−7
Distribution/Client/Configure.hs +59/−37
Distribution/Client/Dependency.hs +164/−91
Distribution/Client/Dependency/Modular.hs +58/−0
Distribution/Client/Dependency/Modular/Assignment.hs +146/−0
Distribution/Client/Dependency/Modular/Builder.hs +143/−0
Distribution/Client/Dependency/Modular/Configured.hs +10/−0
Distribution/Client/Dependency/Modular/ConfiguredConversion.hs +40/−0
Distribution/Client/Dependency/Modular/Dependency.hs +194/−0
Distribution/Client/Dependency/Modular/Explore.hs +148/−0
Distribution/Client/Dependency/Modular/Flag.hs +69/−0
Distribution/Client/Dependency/Modular/Index.hs +33/−0
Distribution/Client/Dependency/Modular/IndexConversion.hs +185/−0
Distribution/Client/Dependency/Modular/Log.hs +96/−0
Distribution/Client/Dependency/Modular/Message.hs +97/−0
Distribution/Client/Dependency/Modular/PSQ.hs +102/−0
Distribution/Client/Dependency/Modular/Package.hs +113/−0
Distribution/Client/Dependency/Modular/Preference.hs +258/−0
Distribution/Client/Dependency/Modular/Solver.hs +52/−0
Distribution/Client/Dependency/Modular/Tree.hs +146/−0
Distribution/Client/Dependency/Modular/Validate.hs +232/−0
Distribution/Client/Dependency/Modular/Version.hs +43/−0
Distribution/Client/Dependency/TopDown.hs +344/−178
Distribution/Client/Dependency/TopDown/Constraints.hs +471/−187
Distribution/Client/Dependency/TopDown/Types.hs +27/−29
Distribution/Client/Dependency/Types.hs +98/−8
Distribution/Client/Fetch.hs +33/−15
Distribution/Client/Haddock.hs +10/−13
Distribution/Client/HttpUtils.hs +20/−12
Distribution/Client/IndexUtils.hs +275/−75
Distribution/Client/Init.hs +250/−87
Distribution/Client/Init/Heuristics.hs +49/−11
Distribution/Client/Init/Licenses.hs +1/−1
Distribution/Client/Init/Types.hs +5/−0
Distribution/Client/Install.hs +291/−109
Distribution/Client/InstallPlan.hs +14/−15
Distribution/Client/InstallSymlink.hs +3/−3
Distribution/Client/List.hs +101/−96
Distribution/Client/PackageIndex.hs +11/−2
Distribution/Client/Setup.hs +297/−92
Distribution/Client/SetupWrapper.hs +13/−6
Distribution/Client/SrcDist.hs +108/−28
Distribution/Client/Tar.hs +1/−1
Distribution/Client/Targets.hs +139/−36
Distribution/Client/Types.hs +37/−13
Distribution/Client/Unpack.hs +9/−7
Distribution/Client/Update.hs +5/−4
Distribution/Client/Upload.hs +18/−23
Main.hs +28/−16
README +5/−15
bootstrap.sh +21/−11
cabal-install.cabal +33/−19

Distribution/Client/BuildReports/Anonymous.hs view

@@ -56,9 +56,9 @@  import qualified Distribution.Compat.ReadP as Parse          ( ReadP, pfail, munch1, skipSpaces )-import qualified Text.PrettyPrint.HughesPJ as Disp+import qualified Text.PrettyPrint as Disp          ( Doc, render, char, text )-import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint          ( (<+>), (<>) )  import Data.List@@ -112,6 +112,7 @@    | SetupFailed    | ConfigureFailed    | BuildFailed+   | TestsFailed    | InstallFailed    | InstallOk   deriving Eq@@ -122,7 +123,7 @@ new :: OS -> Arch -> CompilerId -- -> Version     -> ConfiguredPackage -> BR.BuildResult     -> BuildReport-new os' arch' comp (ConfiguredPackage pkg flags deps) result =+new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =   BuildReport {     package               = packageId pkg,     os                    = os',@@ -143,6 +144,7 @@       Left  (BR.UnpackFailed    _) -> UnpackFailed       Left  (BR.ConfigureFailed _) -> ConfigureFailed       Left  (BR.BuildFailed     _) -> BuildFailed+      Left  (BR.TestsFailed     _) -> TestsFailed       Left  (BR.InstallFailed   _) -> InstallFailed       Right (BR.BuildOk       _ _) -> InstallOk     convertDocsOutcome = case result of@@ -151,9 +153,9 @@       Right (BR.BuildOk BR.DocsFailed _)    -> Failed       Right (BR.BuildOk BR.DocsOk _)        -> Ok     convertTestsOutcome = case result of+      Left  (BR.TestsFailed _)              -> Failed       Left _                                -> NotTried       Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried-      Right (BR.BuildOk _ BR.TestsFailed)   -> Failed       Right (BR.BuildOk _ BR.TestsOk)       -> Ok  cabalInstallID :: PackageIdentifier@@ -280,6 +282,7 @@   disp SetupFailed     = Disp.text "SetupFailed"   disp ConfigureFailed = Disp.text "ConfigureFailed"   disp BuildFailed     = Disp.text "BuildFailed"+  disp TestsFailed     = Disp.text "TestsFailed"   disp InstallFailed   = Disp.text "InstallFailed"   disp InstallOk       = Disp.text "InstallOk" @@ -294,6 +297,7 @@       "SetupFailed"      -> return SetupFailed       "ConfigureFailed"  -> return ConfigureFailed       "BuildFailed"      -> return BuildFailed+      "TestsFailed"      -> return TestsFailed       "InstallFailed"    -> return InstallFailed       "InstallOk"        -> return InstallOk       _                  -> Parse.pfail

Distribution/Client/BuildReports/Storage.hs view

@@ -116,12 +116,12 @@                 -> Maybe (BuildReport, Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of -  InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {-                          packageSource = RepoTarballPackage repo _ _ }) _ _) result+  InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {+                          packageSource = RepoTarballPackage repo _ _ }) _ _ _) result     -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) -  InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {-                       packageSource = RepoTarballPackage repo _ _ }) _ _) result+  InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {+                       packageSource = RepoTarballPackage repo _ _ }) _ _ _) result     -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)    _ -> Nothing

Distribution/Client/BuildReports/Types.hs view

@@ -19,7 +19,7 @@  import qualified Distribution.Compat.ReadP as Parse          ( pfail, munch1 )-import qualified Text.PrettyPrint.HughesPJ as Disp+import qualified Text.PrettyPrint as Disp          ( text )  import Data.Char as Char

Distribution/Client/BuildReports/Upload.hs view

@@ -29,10 +29,8 @@ type BuildLog = String  uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]-              -> BrowserAction (HandleStream String) ()               ->  BrowserAction (HandleStream BuildLog) ()-uploadReports uri reports auth = do-  auth+uploadReports uri reports = do   forM_ reports $ \(report, mbBuildLog) -> do      buildId <- postBuildReport uri report      case mbBuildLog of

Distribution/Client/Config.hs view

@@ -37,16 +37,19 @@          , ReportFlags(..), reportCommand          , showRepo, parseRepo ) +import Distribution.Simple.Compiler+         ( OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags          , installDirsOptions-         , Flag, toFlag, flagToMaybe, fromFlagOrDefault )+         , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs          ( InstallDirs(..), defaultInstallDirs          , PathTemplate, toPathTemplate ) import Distribution.ParseUtils          ( FieldDescr(..), liftField-         , ParseResult(..), locatedErrorMsg, showPWarning+         , ParseResult(..), PError(..), PWarning(..)+         , locatedErrorMsg, showPWarning          , readFields, warning, lineNo          , simpleField, listField, parseFilePathQ, parseTokenQ ) import qualified Distribution.ParseUtils as ParseUtils@@ -76,9 +79,9 @@ import qualified Data.Map as Map import qualified Distribution.Compat.ReadP as Parse          ( option )-import qualified Text.PrettyPrint.HughesPJ as Disp+import qualified Text.PrettyPrint as Disp          ( Doc, render, text, colon, vcat, empty, isEmpty, nest )-import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint          ( (<>), (<+>), ($$), ($+$) ) import System.Directory          ( createDirectoryIfMissing, getAppUserDataDirectory )@@ -343,7 +346,7 @@    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)-       (["builddir", "configure-option"] ++ map fieldName installDirsFields)+       (["builddir", "configure-option", "constraint"] ++ map fieldName installDirsFields)          --FIXME: this is only here because viewAsFieldDescr gives us a parser         -- that only recognises 'ghc' etc, the case-sensitive flag names, not@@ -351,6 +354,31 @@        [simpleField "compiler"           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)           configHcFlavor (\v flags -> flags { configHcFlavor = v })+        -- TODO: The following is a temporary fix. The "optimization" field is+        -- OptArg, and viewAsFieldDescr fails on that. Instead of a hand-written+        -- hackaged parser and printer, we should handle this case properly in+        -- the library.+       ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $+        let name = "optimization" in+        FieldDescr name+          (\f -> case f of+                   Flag NoOptimisation      -> Disp.text "False"+                   Flag NormalOptimisation  -> Disp.text "True"+                   Flag MaximumOptimisation -> Disp.text "2"+                   _                        -> Disp.empty)+          (\line str _ -> case () of+           _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)+             |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)+             |  str == "0"     -> ParseOk [] (Flag NoOptimisation)+             |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)+             |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)+             | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)+             | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalOptimisation)+             | otherwise       -> ParseFailed (NoParse name line)+             where+               lstr = lowercase str+               caseWarning = PWarning $+                 "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")        ]    ++ toSavedConfig liftConfigExFlag@@ -359,7 +387,7 @@    ++ toSavedConfig liftInstallFlag        (installOptions ParseArgs)-       ["dry-run", "reinstall", "only"] []+       ["dry-run", "only"] []    ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)@@ -367,7 +395,11 @@    ++ toSavedConfig liftReportFlag        (commandOptions reportCommand ParseArgs)-       ["verbose"] []+       ["verbose", "username", "password"] []+       --FIXME: this is a hack, hiding the username and password.+       -- But otherwise it masks the upload ones. Either need to+       -- share the options or make then distinct. In any case+       -- they should probably be per-server.    where     toSavedConfig lift options exclusions replacements =

Distribution/Client/Configure.hs view

@@ -18,20 +18,22 @@ import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, getInstalledPackages )+         ( getSourcePackages, getInstalledPackages ) import Distribution.Client.Setup          ( ConfigExFlags(..), configureCommand, filterConfigureFlags )-import Distribution.Client.Types as Available+import Distribution.Client.Types as Source import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Targets+         ( userToPackageConstraint )  import Distribution.Simple.Compiler          ( CompilerId(..), Compiler(compilerId)          , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup-         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Client.PackageIndex (PackageIndex)+         ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Utils          ( defaultPackageDesc ) import Distribution.Package@@ -64,11 +66,11 @@ configure verbosity packageDBs repos comp conf   configFlags configExFlags extraArgs = do -  installed <- getInstalledPackages verbosity comp packageDBs conf-  available <- getAvailablePackages verbosity repos+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  sourcePkgDb       <- getSourcePackages    verbosity repos    progress <- planLocalPackage verbosity comp configFlags configExFlags-                               installed available+                               installedPkgIndex sourcePkgDb    notice verbosity "Resolving dependencies..."   maybePlan <- foldProgress logMsg (return . Left) (return . Right)@@ -76,15 +78,15 @@   case maybePlan of     Left message -> do       info verbosity message-      setupWrapper verbosity (setupScriptOptions installed) Nothing+      setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing         configureCommand (const configFlags) extraArgs      Right installPlan -> case InstallPlan.ready installPlan of-      [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] ->+      [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _ _)] ->         configurePackage verbosity           (InstallPlan.planPlatform installPlan)           (InstallPlan.planCompiler installPlan)-          (setupScriptOptions installed)+          (setupScriptOptions installedPkgIndex)           configFlags pkg extraArgs        _ -> die $ "internal error: configure install plan should have exactly "@@ -95,15 +97,8 @@       useCabalVersion  = maybe anyVersion thisVersion                          (flagToMaybe (configCabalVersion configExFlags)),       useCompiler      = Just comp,-      -- Hack: we typically want to allow the UserPackageDB for finding the-      -- Cabal lib when compiling any Setup.hs even if we're doing a global-      -- install. However we also allow looking in a specific package db.-      usePackageDB     = if UserPackageDB `elem` packageDBs-                           then packageDBs-                           else packageDBs ++ [UserPackageDB],-      usePackageIndex  = if UserPackageDB `elem` packageDBs-                           then Just index-                           else Nothing,+      usePackageDB     = packageDBs',+      usePackageIndex  = index',       useProgramConfig = conf,       useDistPref      = fromFlagOrDefault                            (useDistPref defaultSetupScriptOptions)@@ -111,6 +106,16 @@       useLoggingHandle = Nothing,       useWorkingDir    = Nothing     }+      where+        -- Hack: we typically want to allow the UserPackageDB for finding the+        -- Cabal lib when compiling any Setup.hs even if we're doing a global+        -- install. However we also allow looking in a specific package db.+        (packageDBs', index') =+          case packageDBs of+            (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs+                -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)+            -- but if the user is using an odd db stack, don't touch it+            dbs -> (dbs, Just index)      logMsg message rest = debug verbosity message >> rest @@ -119,20 +124,25 @@ -- planLocalPackage :: Verbosity -> Compiler                  -> ConfigFlags -> ConfigExFlags-                 -> PackageIndex InstalledPackage-                 -> AvailablePackageDb+                 -> PackageIndex+                 -> SourcePackageDb                  -> IO (Progress String String InstallPlan)-planLocalPackage verbosity comp configFlags configExFlags installed-  (AvailablePackageDb _ availablePrefs) = do+planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex+  (SourcePackageDb _ packagePrefs) = do   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity+  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp)    let -- We create a local package and ask to resolve a dependency on it-      localPkg = AvailablePackage {-        packageInfoId                = packageId pkg,-        Available.packageDescription = pkg,-        packageSource                = LocalUnpackedPackage "."+      localPkg = SourcePackage {+        packageInfoId             = packageId pkg,+        Source.packageDescription = pkg,+        packageSource             = LocalUnpackedPackage "."       } +      testsEnabled = fromFlagOrDefault False $ configTests configFlags+      benchmarksEnabled =+        fromFlagOrDefault False $ configBenchmarks configFlags+       resolverParams =            addPreferences@@ -142,23 +152,33 @@          . addConstraints             -- version constraints from the config file or command line-            [ PackageVersionConstraint name ver-            | Dependency name ver <- configConstraints configFlags ]+            -- TODO: should warn or error on constraints that are not on direct deps+            -- or flag constraints not on the package in question.+            (map userToPackageConstraint (configExConstraints configExFlags))          . addConstraints             -- package flags from the config file or command line-            [ PackageFlagsConstraint (packageName pkg)+            [ PackageConstraintFlags (packageName pkg)                                      (configConfigurationsFlags configFlags) ] +        . addConstraints+            -- '--enable-tests' and '--enable-benchmarks' constraints from+            -- command line+            [ PackageConstraintStanzas (packageName pkg) $ concat+                [ if testsEnabled then [TestStanzas] else []+                , if benchmarksEnabled then [BenchStanzas] else []+                ]+            ]+         $ standardInstallPolicy-            installed-            (AvailablePackageDb mempty availablePrefs)+            installedPkgIndex+            (SourcePackageDb mempty packagePrefs)             [SpecificSourcePackage localPkg] -  return (resolveDependencies buildPlatform (compilerId comp) resolverParams)+  return (resolveDependencies buildPlatform (compilerId comp) solver resolverParams)  --- | Call an installer for an 'AvailablePackage' but override the configure+-- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the -- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly -- versioned package dependencies. So we ignore any previous partial flag@@ -172,7 +192,7 @@                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =+  (ConfiguredPackage (SourcePackage _ gpkg _) flags stanzas deps) extraArgs =    setupWrapper verbosity     scriptOptions (Just pkg) configureCommand configureFlags extraArgs@@ -181,11 +201,13 @@     configureFlags   = filterConfigureFlags configFlags {       configConfigurationsFlags = flags,       configConstraints         = map thisPackageVersion deps,-      configVerbosity           = toFlag verbosity+      configVerbosity           = toFlag verbosity,+      configBenchmarks          = toFlag (BenchStanzas `elem` stanzas),+      configTests               = toFlag (TestStanzas `elem` stanzas)     }      pkg = case finalizePackageDescription flags            (const True)-           platform comp [] gpkg of+           platform comp [] (enableStanzas stanzas gpkg) of       Left _ -> error "finalizePackageDescription ConfiguredPackage failed"       Right (desc, _) -> desc

Distribution/Client/Dependency.hs view

@@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module Distribution.Client.Dependency (     -- * The main package dependency resolver+    chooseSolver,     resolveDependencies,     Progress(..),     foldProgress,@@ -42,44 +43,57 @@     addConstraints,     addPreferences,     setPreferenceDefault,-    addAvailablePackages,-    hideInstalledPackagesSpecific,+    setReorderGoals,+    setIndependentGoals,+    setAvoidReinstalls,+    setShadowPkgs,+    setMaxBackjumps,+    addSourcePackages,+    hideInstalledPackagesSpecificByInstalledPackageId,+    hideInstalledPackagesSpecificBySourcePackageId,     hideInstalledPackagesAllVersions,   ) where -import Distribution.Client.Dependency.TopDown (topDownResolver)+import Distribution.Client.Dependency.TopDown+         ( topDownResolver )+import Distribution.Client.Dependency.Modular+         ( modularResolver, SolverConfig(..) ) import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Types-         ( AvailablePackageDb(AvailablePackageDb)-         , AvailablePackage(..), InstalledPackage )+         ( SourcePackageDb(SourcePackageDb)+         , SourcePackage(..) ) import Distribution.Client.Dependency.Types-         ( DependencyResolver, PackageConstraint(..)+         ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)          , PackagePreferences(..), InstalledPreference(..)+         , PackagesPreferenceDefault(..)          , Progress(..), foldProgress ) import Distribution.Client.Targets+import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package          ( PackageName(..), PackageId, Package(..), packageVersion-         , Dependency(Dependency))+         , InstalledPackageId, Dependency(Dependency)) import Distribution.Version-         ( VersionRange, anyVersion, withinRange, simplifyVersionRange )+         ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange ) import Distribution.Compiler-         ( CompilerId(..) )+         ( CompilerId(..), CompilerFlavor(..) ) import Distribution.System          ( Platform )-import Distribution.Simple.Utils (comparing)+import Distribution.Simple.Utils+         ( comparing, warn, info ) import Distribution.Text          ( display )+import Distribution.Verbosity+         ( Verbosity )  import Data.List (maximumBy, foldl')-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) - -- ------------------------------------------------------------ -- * High level planner policy -- ------------------------------------------------------------@@ -93,36 +107,16 @@        depResolverConstraints       :: [PackageConstraint],        depResolverPreferences       :: [PackagePreference],        depResolverPreferenceDefault :: PackagesPreferenceDefault,-       depResolverInstalled         :: PackageIndex InstalledPackage,-       depResolverAvailable         :: PackageIndex AvailablePackage+       depResolverInstalledPkgIndex :: InstalledPackageIndex.PackageIndex,+       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex SourcePackage,+       depResolverReorderGoals      :: Bool,+       depResolverIndependentGoals  :: Bool,+       depResolverAvoidReinstalls   :: Bool,+       depResolverShadowPkgs        :: Bool,+       depResolverMaxBackjumps      :: Maybe Int      }  --- | Global policy for all packages to say if we prefer package versions that--- are already installed locally or if we just prefer the latest available.----data PackagesPreferenceDefault =--     -- | Always prefer the latest version irrespective of any existing-     -- installed version.-     ---     -- * This is the standard policy for upgrade.-     ---     PreferAllLatest--     -- | Always prefer the installed versions over ones that would need to be-     -- installed. Secondarily, prefer latest versions (eg the latest installed-     -- version or if there are none then the latest available version).-   | PreferAllInstalled--     -- | Prefer the latest version for packages that are explicitly requested-     -- but prefers the installed version for any other packages.-     ---     -- * This is the standard policy for install.-     ---   | PreferLatestForSelected-- -- | A package selection preference for a particular package. -- -- Preferences are soft constraints that the dependency resolver should try to@@ -137,17 +131,22 @@      -- | If we prefer versions of packages that are already installed.    | PackageInstalledPreference PackageName InstalledPreference -basicDepResolverParams :: PackageIndex InstalledPackage-                       -> PackageIndex AvailablePackage+basicDepResolverParams :: InstalledPackageIndex.PackageIndex+                       -> PackageIndex.PackageIndex SourcePackage                        -> DepResolverParams-basicDepResolverParams installed available =+basicDepResolverParams installedPkgIndex sourcePkgIndex =     DepResolverParams {        depResolverTargets           = [],        depResolverConstraints       = [],        depResolverPreferences       = [],        depResolverPreferenceDefault = PreferLatestForSelected,-       depResolverInstalled         = installed,-       depResolverAvailable         = available+       depResolverInstalledPkgIndex = installedPkgIndex,+       depResolverSourcePkgIndex    = sourcePkgIndex,+       depResolverReorderGoals      = False,+       depResolverIndependentGoals  = False,+       depResolverAvoidReinstalls   = False,+       depResolverShadowPkgs        = False,+       depResolverMaxBackjumps      = Nothing      }  addTargets :: [PackageName]@@ -180,12 +179,42 @@       depResolverPreferenceDefault = preferenceDefault     } +setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams+setReorderGoals b params =+    params {+      depResolverReorderGoals = b+    }++setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams+setIndependentGoals b params =+    params {+      depResolverIndependentGoals = b+    }++setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams+setAvoidReinstalls b params =+    params {+      depResolverAvoidReinstalls = b+    }++setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams+setShadowPkgs b params =+    params {+      depResolverShadowPkgs = b+    }++setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams+setMaxBackjumps n params =+    params {+      depResolverMaxBackjumps = n+    }+ dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams dontUpgradeBasePackage params =     addConstraints extraConstraints params   where     extraConstraints =-      [ PackageInstalledConstraint pkgname+      [ PackageConstraintInstalled pkgname       | all (/=PackageName "base") (depResolverTargets params)       , pkgname <-  [ PackageName "base", PackageName "ghc-prim" ]       , isInstalled pkgname ]@@ -193,45 +222,59 @@     -- below when there are no targets and thus no dep on base.     -- Need to refactor contraints separate from needing packages.     isInstalled = not . null-                . PackageIndex.lookupPackageName (depResolverInstalled params)+                . InstalledPackageIndex.lookupPackageName+                                 (depResolverInstalledPkgIndex params) -addAvailablePackages :: [AvailablePackage]-                     -> DepResolverParams -> DepResolverParams-addAvailablePackages pkgs params =+addSourcePackages :: [SourcePackage]+                  -> DepResolverParams -> DepResolverParams+addSourcePackages pkgs params =     params {-      depResolverAvailable = foldl (flip PackageIndex.insert)-                                   (depResolverAvailable params) pkgs+      depResolverSourcePkgIndex =+        foldl (flip PackageIndex.insert)+              (depResolverSourcePkgIndex params) pkgs     } -hideInstalledPackagesSpecific :: [PackageId]-                              -> DepResolverParams -> DepResolverParams-hideInstalledPackagesSpecific pkgids params =+hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]+                                                     -> DepResolverParams -> DepResolverParams+hideInstalledPackagesSpecificByInstalledPackageId pkgids params =     --TODO: this should work using exclude constraints instead     params {-      depResolverInstalled = foldl' (flip PackageIndex.deletePackageId)-                                    (depResolverInstalled params) pkgids+      depResolverInstalledPkgIndex =+        foldl' (flip InstalledPackageIndex.deleteInstalledPackageId)+               (depResolverInstalledPkgIndex params) pkgids     } +hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]+                                                  -> DepResolverParams -> DepResolverParams+hideInstalledPackagesSpecificBySourcePackageId pkgids params =+    --TODO: this should work using exclude constraints instead+    params {+      depResolverInstalledPkgIndex =+        foldl' (flip InstalledPackageIndex.deleteSourcePackageId)+               (depResolverInstalledPkgIndex params) pkgids+    }+ hideInstalledPackagesAllVersions :: [PackageName]                                  -> DepResolverParams -> DepResolverParams hideInstalledPackagesAllVersions pkgnames params =     --TODO: this should work using exclude constraints instead     params {-      depResolverInstalled =-        foldl' (flip PackageIndex.deletePackageName)-               (depResolverInstalled params) pkgnames+      depResolverInstalledPkgIndex =+        foldl' (flip InstalledPackageIndex.deletePackageName)+               (depResolverInstalledPkgIndex params) pkgnames     }   hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams hideBrokenInstalledPackages params =-    hideInstalledPackagesSpecific pkgids params+    hideInstalledPackagesSpecificByInstalledPackageId pkgids params   where-    pkgids = map packageId-           . PackageIndex.reverseDependencyClosure (depResolverInstalled params)-           . map (packageId . fst)-           . PackageIndex.brokenPackages-           $ depResolverInstalled params+    pkgids = map Installed.installedPackageId+           . InstalledPackageIndex.reverseDependencyClosure+                            (depResolverInstalledPkgIndex params)+           . map (Installed.installedPackageId . fst)+           . InstalledPackageIndex.brokenPackages+           $ depResolverInstalledPkgIndex params   upgradeDependencies :: DepResolverParams -> DepResolverParams@@ -243,16 +286,17 @@     hideInstalledPackagesAllVersions (depResolverTargets params) params  -standardInstallPolicy :: PackageIndex InstalledPackage-                      -> AvailablePackageDb-                      -> [PackageSpecifier AvailablePackage]+standardInstallPolicy :: InstalledPackageIndex.PackageIndex+                      -> SourcePackageDb+                      -> [PackageSpecifier SourcePackage]                       -> DepResolverParams standardInstallPolicy-    installed (AvailablePackageDb available availablePrefs) pkgSpecifiers+    installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)+    pkgSpecifiers    = addPreferences       [ PackageVersionPreference name ver-      | (name, ver) <- Map.toList availablePrefs ]+      | (name, ver) <- Map.toList sourcePkgPrefs ]    . addConstraints       (concatMap pkgSpecifierConstraints pkgSpecifiers)@@ -260,23 +304,35 @@   . addTargets       (map pkgSpecifierTarget pkgSpecifiers) -  . hideInstalledPackagesSpecific+  . hideInstalledPackagesSpecificBySourcePackageId       [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] -  . addAvailablePackages+  . addSourcePackages       [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]    $ basicDepResolverParams-      installed available+      installedPkgIndex sourcePkgIndex   -- ------------------------------------------------------------ -- * Interface to the standard resolver -- ------------------------------------------------------------ -defaultResolver :: DependencyResolver-defaultResolver = topDownResolver+chooseSolver :: Verbosity -> PreSolver -> CompilerId -> IO Solver+chooseSolver _         AlwaysTopDown _                = return TopDown+chooseSolver _         AlwaysModular _                = return Modular+chooseSolver verbosity Choose        (CompilerId f v) = do+  let chosenSolver | f == GHC && v <= Version [7] [] = TopDown+                   | otherwise                       = Modular+      msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7."+      msg Modular = info verbosity "Choosing modular solver."+  msg chosenSolver+  return chosenSolver +runSolver :: Solver -> SolverConfig -> DependencyResolver+runSolver TopDown = const topDownResolver -- TODO: warn about unsuported options+runSolver Modular = modularResolver+ -- | Run the dependency solver. -- -- Since this is potentially an expensive operation, the result is wrapped in a@@ -285,26 +341,40 @@ -- resolveDependencies :: Platform                     -> CompilerId+                    -> Solver                     -> DepResolverParams                     -> Progress String String InstallPlan      --TODO: is this needed here? see dontUpgradeBasePackage-resolveDependencies platform comp params+resolveDependencies platform comp _solver params   | null (depResolverTargets params)   = return (mkInstallPlan platform comp []) -resolveDependencies platform comp params =+resolveDependencies platform comp  solver params =      fmap (mkInstallPlan platform comp)-  $ defaultResolver platform comp installed available-                    preferences constraints targets+  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps)+                     platform comp installedPkgIndex sourcePkgIndex+                     preferences constraints targets   where     DepResolverParams       targets constraints       prefs defpref-      installed available = dontUpgradeBasePackage-                          . hideBrokenInstalledPackages-                          $ params+      installedPkgIndex+      sourcePkgIndex+      reorderGoals+      indGoals+      noReinstalls+      shadowing+      maxBkjumps      = dontUpgradeBasePackage+                      -- TODO:+                      -- The modular solver can properly deal with broken packages+                      -- and won't select them. So the 'hideBrokenInstalledPackages'+                      -- function should be moved into a module that is specific+                      -- to the Topdown solver.+                      . (if solver /= Modular then hideBrokenInstalledPackages+                                              else id)+                      $ params      preferences = interpretPackagesPreference                     (Set.fromList targets) defpref prefs@@ -316,8 +386,8 @@ mkInstallPlan :: Platform               -> CompilerId               -> [InstallPlan.PlanPackage] -> InstallPlan-mkInstallPlan platform comp pkgs =-  case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of+mkInstallPlan platform comp pkgIndex =+  case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of     Right plan     -> plan     Left  problems -> error $ unlines $         "internal error: could not construct a valid install plan."@@ -375,12 +445,13 @@ -- It simply means preferences for installed packages will be ignored. -- resolveWithoutDependencies :: DepResolverParams-                           -> Either [ResolveNoDepsError] [AvailablePackage]+                           -> Either [ResolveNoDepsError] [SourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints-                                prefs defpref installed available) =+                              prefs defpref installedPkgIndex sourcePkgIndex+                              _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) =     collectEithers (map selectPackage targets)   where-    selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage+    selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage     selectPackage pkgname       | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions       | otherwise    = Right $! maximumBy bestByPrefs choices@@ -389,7 +460,8 @@         -- Constraints         requiredVersions = packageConstraints pkgname         pkgDependency    = Dependency pkgname requiredVersions-        choices          = PackageIndex.lookupDependency available pkgDependency+        choices          = PackageIndex.lookupDependency sourcePkgIndex+                                                         pkgDependency          -- Preferences         PackagePreferences preferredVersions preferInstalled@@ -399,7 +471,8 @@                           (installPref pkg, versionPref pkg, packageVersion pkg)         installPref   = case preferInstalled of           PreferLatest    -> const False-          PreferInstalled -> isJust . PackageIndex.lookupPackageId installed+          PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId+                                                     installedPkgIndex                            . packageId         versionPref   pkg = packageVersion pkg `withinRange` preferredVersions @@ -408,7 +481,7 @@       Map.findWithDefault anyVersion pkgname packageVersionConstraintMap     packageVersionConstraintMap =       Map.fromList [ (name, range)-                   | PackageVersionConstraint name range <- constraints ]+                   | PackageConstraintVersion name range <- constraints ]      packagePreferences :: PackageName -> PackagePreferences     packagePreferences = interpretPackagesPreference

+ Distribution/Client/Dependency/Modular.hs view

@@ -0,0 +1,58 @@+module Distribution.Client.Dependency.Modular+         ( modularResolver, SolverConfig(..)) where++-- Here, we try to map between the external cabal-install solver+-- interface and the internal interface that the solver actually+-- expects. There are a number of type conversions to perform: we+-- have to convert the package indices to the uniform index used+-- by the solver; we also have to convert the initial constraints;+-- and finally, we have to convert back the resulting install+-- plan.++import Data.Map as M+         ( fromListWith )+import Distribution.Client.Dependency.Modular.Assignment+         ( Assignment, toCPs )+import Distribution.Client.Dependency.Modular.Dependency+         ( RevDepMap )+import Distribution.Client.Dependency.Modular.ConfiguredConversion+         ( convCP )+import Distribution.Client.Dependency.Modular.IndexConversion+         ( convPIs )+import Distribution.Client.Dependency.Modular.Log+         ( logToProgress )+import Distribution.Client.Dependency.Modular.Package+         ( PN )+import Distribution.Client.Dependency.Modular.Solver+         ( SolverConfig(..), solve )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, PackageConstraint(..) )+import Distribution.Client.InstallPlan+         ( PlanPackage )+import Distribution.System+         ( Platform(..) )++-- | Ties the two worlds together: classic cabal-install vs. the modular+-- solver. Performs the necessary translations before and after.+modularResolver :: SolverConfig -> DependencyResolver+modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns =+  fmap (uncurry postprocess)      $ -- convert install plan+  logToProgress (maxBackjumps sc) $ -- convert log format into progress format+  solve sc idx pprefs gcs pns+    where+      -- Indices have to be converted into solver-specific uniform index.+      idx    = convPIs os arch cid (shadowPkgs sc) iidx sidx+      -- Constraints have to be converted into a finite map indexed by PN.+      gcs    = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)++      -- Results have to be converted into an install plan.+      postprocess :: Assignment -> RevDepMap -> [PlanPackage]+      postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)++      -- Helper function to extract the PN from a constraint.+      pcName :: PackageConstraint -> PN+      pcName (PackageConstraintVersion   pn _) = pn+      pcName (PackageConstraintInstalled pn  ) = pn+      pcName (PackageConstraintSource    pn  ) = pn+      pcName (PackageConstraintFlags     pn _) = pn+      pcName (PackageConstraintStanzas   pn _) = pn

+ Distribution/Client/Dependency/Modular/Assignment.hs view

@@ -0,0 +1,146 @@+module Distribution.Client.Dependency.Modular.Assignment where++import Control.Applicative+import Control.Monad+import Data.Array as A+import Data.List as L+import Data.Map as M+import Data.Maybe+import Data.Graph+import Prelude hiding (pi)++import Distribution.PackageDescription (FlagAssignment) -- from Cabal+import Distribution.Client.Types (OptionalStanza)++import Distribution.Client.Dependency.Modular.Configured+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.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++-- | A (partial) assignment of variables.+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.+--+-- Either returns a witness of the conflict that would arise during the merge,+-- or the successfully extended assignment.+extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment+extend var pa qa = foldM (\ a (Dep 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 qpn) (simplify (P qpn) d d'))+                           Right x           -> Right x)+                    pa qa+  where+    -- 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 _ (Goal var' _)) c | v == var && var' == var = [c]+    simplify v c (Fixed _ (Goal 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+-- w.r.t. unqualification. There might be several different instances+-- of one package version chosen by the solver, which will lead to+-- clashes.+toCPs :: Assignment -> RevDepMap -> [CP QPN]+toCPs (A pa fa sa) rdm =+  let+    -- get hold of the graph+    g   :: Graph+    vm  :: Vertex -> ((), QPN, [QPN])+    cvm :: QPN -> Maybe Vertex+    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.+    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))+                                  (M.toList rdm))+    tg :: Graph+    tg = transposeG g+    -- Topsort the dependency graph, yielding a list of pkgs in the right order.+    -- The graph will still contain all the installed packages, and it might+    -- contain duplicates, because several variables might actually resolve to+    -- the same package in the presence of qualified package names.+    ps :: [PI QPN]+    ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $+         topSort g+    -- 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)])) $+           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 [])) $+           M.toList $+           sa+    -- Dependencies per package.+    depp :: QPN -> [PI QPN]+    depp qpn = let v :: Vertex+                   v   = fromJust (cvm qpn)+                   dvs :: [Vertex]+                   dvs = tg A.! v+               in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs+  in+    L.map (\ pi@(PI qpn _) -> CP pi+                                 (M.findWithDefault [] qpn fapp)+                                 (M.findWithDefault [] qpn sapp)+                                 (depp qpn))+          ps++-- | Finalize an assignment and a reverse dependency map.+--+-- This is preliminary, and geared towards output right now.+finalize :: Index -> Assignment -> RevDepMap -> IO ()+finalize idx (A pa fa _) rdm =+  let+    -- get hold of the graph+    g  :: Graph+    vm :: Vertex -> ((), QPN, [QPN])+    (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))+    -- topsort the dependency graph, yielding a list of pkgs in the right order+    f :: [PI QPN]+    f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g))+    fapp :: Map QPN [(QFN, Bool)] -- flags per package+    fapp = M.fromListWith (++) $+           L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa+    -- print one instance+    ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp)+    -- print install status+    status :: PI QPN -> String+    status (PI (Q _ pn) _) =+      case insts of+        [] -> " (new)"+        vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")"+      where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $+                    M.keys (M.findWithDefault M.empty pn idx)+            isInstalled (I _ (Inst _ )) = True+            isInstalled _               = False+    -- print flag assignment+    pflags = unwords . L.map (uncurry showFBool)+  in+    -- show packages with associated flag assignments+    putStr (unlines (L.map ppi f))

+ Distribution/Client/Dependency/Modular/Builder.hs view

@@ -0,0 +1,143 @@+module Distribution.Client.Dependency.Modular.Builder where++-- Building the search tree.+--+-- In this phase, we build a search tree that is too large, i.e, it contains+-- invalid solutions. We keep track of the open goals at each point. We+-- nondeterministically pick an open goal (via a goal choice node), create+-- subtrees according to the index and the available solutions, and extend the+-- set of open goals by superficially looking at the dependencies recorded in+-- the index.+--+-- For each goal, we keep track of all the *reasons* why it is being+-- introduced. These are for debugging and error messages, mainly. A little bit+-- of care has to be taken due to the way we treat flags. If a package has+-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we+-- store the entire dependency.++import Control.Monad.Reader hiding (sequence, mapM)+import Data.List as L+import Data.Map as M+import Prelude hiding (sequence, mapM)++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree++-- | The state needed during the build phase of the search tree.+data BuildState = BS {+  index :: Index,           -- ^ information about packages and their dependencies+  scope :: Scope,           -- ^ information about encapsulations+  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+}++-- | Extend the set of open goals with the new goals listed.+--+-- We also adjust the map of overall goals, and keep track of the+-- reverse dependencies of each of the goals.+extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState+extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs+  where+    go g o []                                             = s { rdeps = g, open = o }+    go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs+    go g o (ng@(OpenGoal (Stanza  _   _  )    _gr) : ngs) = go g (cons ng () o) ngs+    go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs)+      | qpn == qpn'                                       = go                       g              o  ngs+                                       -- we ignore self-dependencies at this point; TODO: more care may be needed+      | qpn `M.member` g                                  = go (M.adjust (qpn':) qpn g)             o  ngs+      | otherwise                                         = go (M.insert qpn [qpn']  g) (cons ng () o) ngs+                                       -- code above is correct; insert/adjust have different arg order++-- | Update the current scope by taking into account the encapsulations that+-- are defined for the current package.+establishScope :: QPN -> Encaps -> BuildState -> BuildState+establishScope (Q pp pn) ecs s =+    s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs }+  where+    pp' = pn : pp -- new path++-- | 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 -> QGoalReasons -> FlaggedDeps PN -> FlagDefaults ->+                    BuildState -> BuildState+scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s+  where+    sc     = scope s+    qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names+    qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs+    gs     = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs)++data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons++build :: BuildState -> Tree (QGoalReasons, Scope)+build = ana go+  where+    go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState++    -- If we have a choice between many goals, we just record the choice in+    -- the tree. We select each open goal in turn, and before we descend, remove+    -- it from the queue of open goals.+    go bs@(BS { rdeps = rds, open = gs, next = Goals })+      | P.null gs = DoneF rds+      | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })+                                              (P.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.+    go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =+      case M.lookup pn idx of+        Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)+        Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) ->+                                                           (i, bs { next = Instance qpn i info gr }))+                                                         (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.+    --+    -- TODO: Should we include the flag default in the tree?+    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) b t f) gr) }) =+      FChoiceF qfn (gr, sc) trivial (P.fromList (reorder b+        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),+         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))+      where+        reorder True  = id+        reorder False = reverse+        trivial = L.null t && L.null f++    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =+      SChoiceF qsn (gr, sc) trivial (P.fromList+        [(False,                                                                        bs  { next = Goals }),+         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])+      where+        trivial = L.null t++    -- For a particular instance, we change the state: we update the scope,+    -- and furthermore we update the set of goals.+    --+    -- TODO: We could inline this above.+    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) =+      go ((establishScope qpn ecs+             (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs))+             { next = Goals })++-- | Interface to the tree builder. Just takes an index and a list of package names,+-- and computes the initial state and then the tree from there.+buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasons, Scope)+buildTree idx ind igs =+    build (BS idx sc+                  (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))+                  (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))+                  Goals)+  where+    sc | ind       = makeIndependent igs+       | otherwise = emptyScope+    qpns           = L.map (qualify sc) igs

+ Distribution/Client/Dependency/Modular/Configured.hs view

@@ -0,0 +1,10 @@+module Distribution.Client.Dependency.Modular.Configured where++import Distribution.PackageDescription (FlagAssignment) -- from Cabal+import Distribution.Client.Types (OptionalStanza)++import Distribution.Client.Dependency.Modular.Package++-- | A configured package is a package instance together with+-- a flag assignment and complete dependencies.+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] [PI qpn]

+ Distribution/Client/Dependency/Modular/ConfiguredConversion.hs view

@@ -0,0 +1,40 @@+module Distribution.Client.Dependency.Modular.ConfiguredConversion where++import Data.Maybe+import Prelude hiding (pi)++import Distribution.Client.InstallPlan+import Distribution.Client.Types+import Distribution.Compiler+import qualified Distribution.Client.PackageIndex as CI+import qualified Distribution.Simple.PackageIndex as SI+import Distribution.System++import Distribution.Client.Dependency.Modular.Configured+import Distribution.Client.Dependency.Modular.Package++mkPlan :: Platform -> CompilerId ->+          SI.PackageIndex -> CI.PackageIndex SourcePackage ->+          [CP QPN] -> Either [PlanProblem] InstallPlan+mkPlan plat comp iidx sidx cps =+  new plat comp (CI.fromList (map (convCP iidx sidx) cps))++convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage ->+          CP QPN -> PlanPackage+convCP iidx sidx (CP qpi fa es ds) =+  case convPI qpi of+    Left  pi -> PreExisting $ InstalledPackage+                  (fromJust $ SI.lookupInstalledPackageId iidx pi)+                  (map convPI' ds)+    Right pi -> Configured $ ConfiguredPackage+                  (fromJust $ CI.lookupPackageId sidx pi)+                  fa+                  es+                  (map convPI' ds)++convPI :: PI QPN -> Either InstalledPackageId PackageId+convPI (PI _ (I _ (Inst pi))) = Left pi+convPI qpi                    = Right $ convPI' qpi++convPI' :: PI QPN -> PackageId+convPI' (PI (Q _ pn) (I v _))  = PackageIdentifier pn v

+ Distribution/Client/Dependency/Modular/Dependency.hs view

@@ -0,0 +1,194 @@+module Distribution.Client.Dependency.Modular.Dependency where++import Prelude hiding (pi)++import Data.List as L+import Data.Map as M+import Data.Set as S++import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Version++-- | The type of variables that play a role in the solver.+-- Note that the tree currently does not use this type directly,+-- and rather has separate tree nodes for the different types of+-- variables. This fits better with the fact that in most cases,+-- these have to be treated differently.+--+-- TODO: This isn't the ideal location to declare the type,+-- but we need them for constrained instances.+data Var qpn = P qpn | F (FN qpn) | S (SN qpn)+  deriving (Eq, Ord, Show)++showVar :: Var QPN -> String+showVar (P qpn) = showQPN qpn+showVar (F qfn) = showQFN qfn+showVar (S qsn) = showQSN qsn++instance Functor Var where+  fmap f (P n)  = P (f n)+  fmap f (F fn) = F (fmap f fn)+  fmap f (S sn) = S (fmap f sn)++type ConflictSet qpn = Set (Var qpn)++showCS :: ConflictSet QPN -> String+showCS = intercalate ", " . L.map showVar . S.toList++-- | 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 (Goal qpn) | Constrained [VROrigin qpn]+  deriving (Eq, Show)++instance Functor CI where+  fmap f (Fixed i g)       = Fixed i (fmap f g)+  fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs)++instance ResetGoal CI where+  resetGoal g (Fixed i _)       = Fixed i g+  resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)++type VROrigin qpn = (VR, Goal qpn)++-- | 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 (.&&.) anyVR . L.map fst++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 :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)+merge c@(Fixed i g1)       d@(Fixed j g2)+  | i == j                                    = Right c+  | otherwise                                 = Left (S.union (toConflictSet g1) (toConflictSet 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 (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))+merge c@(Constrained _)    d@(Fixed _ _)      = merge d c+merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))+++type FlaggedDeps qpn = [FlaggedDep qpn]++-- | Flagged dependencies can either be plain dependency constraints,+-- or flag-dependent dependency trees.+data FlaggedDep qpn =+    Flagged (FN qpn) FDefault (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)+  | Stanza  (SN qpn)          (TrueFlaggedDeps qpn)+  | Simple (Dep qpn)+  deriving (Eq, Show)++instance Functor FlaggedDep where+  fmap f (Flagged x y tt ff) = Flagged (fmap f x) y+                                       (fmap (fmap f) tt) (fmap (fmap f) ff)+  fmap f (Stanza x tt)       = Stanza (fmap f x) (fmap (fmap f) tt)+  fmap f (Simple d)          = Simple (fmap f d)++type TrueFlaggedDeps  qpn = FlaggedDeps qpn+type FalseFlaggedDeps qpn = FlaggedDeps qpn++-- | A dependency (constraint) associates a package name with a+-- constrained instance.+data Dep qpn = Dep qpn (CI qpn)+  deriving (Eq, Show)++showDep :: Dep QPN -> String+showDep (Dep qpn (Fixed i (Goal v _))          ) =+  (if P qpn /= v then showVar v ++ " => " else "") +++  showQPN qpn ++ "==" ++ showI i+showDep (Dep qpn (Constrained [(vr, Goal v _)])) =+  showVar v ++ " => " ++ showQPN qpn ++ showVR vr+showDep (Dep qpn ci                            ) =+  showQPN qpn ++ showCI ci++instance Functor Dep where+  fmap f (Dep x y) = Dep (f x) (fmap f y)++instance ResetGoal Dep where+  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)++-- | A map containing reverse dependencies between qualified+-- package names.+type RevDepMap = Map QPN [QPN]++-- | Goals are solver variables paired with information about+-- why they have been introduced.+data Goal qpn = Goal (Var qpn) (GoalReasons qpn)+  deriving (Eq, Show)++instance Functor Goal where+  fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr)++class ResetGoal f where+  resetGoal :: Goal qpn -> f qpn -> f qpn++instance ResetGoal Goal where+  resetGoal = const++-- | For open goals as they occur during the build phase, we need to store+-- additional information about flags.+data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons+  deriving (Eq, Show)++-- | Reasons why a goal can be added to a goal set.+data GoalReason qpn =+    UserGoal+  | PDependency (PI qpn)+  | FDependency (FN qpn) Bool+  | SDependency (SN qpn)+  deriving (Eq, Show)++instance Functor GoalReason where+  fmap _ UserGoal           = UserGoal+  fmap f (PDependency pi)   = PDependency (fmap f pi)+  fmap f (FDependency fn b) = FDependency (fmap f fn) b+  fmap f (SDependency sn)   = SDependency (fmap f sn)++-- | The first element is the immediate reason. The rest are the reasons+-- for the reasons ...+type GoalReasons qpn = [GoalReason qpn]++type QGoalReasons = GoalReasons QPN++goalReasonToVars :: GoalReason qpn -> ConflictSet qpn+goalReasonToVars UserGoal                 = S.empty+goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)+goalReasonToVars (FDependency qfn _)      = S.singleton (F qfn)+goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)++goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn+goalReasonsToVars = S.unions . L.map goalReasonToVars++-- | Closes a goal, i.e., removes all the extraneous information that we+-- need only during the build phase.+close :: OpenGoal -> Goal QPN+close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr+close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr+close (OpenGoal (Stanza  qsn _)      gr) = Goal (S qsn) gr++-- | Compute a conflic set from a goal. The conflict set contains the+-- closure of goal reasons as well as the variable of the goal itself.+toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn+toConflictSet (Goal g gr) = S.insert g (goalReasonsToVars gr)

+ Distribution/Client/Dependency/Modular/Explore.hs view

@@ -0,0 +1,148 @@+module Distribution.Client.Dependency.Modular.Explore where++import Control.Applicative as A+import Data.Foldable+import Data.List as L+import Data.Map as M+import Data.Set as S++import Distribution.Client.Dependency.Modular.Assignment+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Log+import Distribution.Client.Dependency.Modular.Message+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree++-- | Backjumping.+--+-- A tree traversal that tries to propagate conflict sets+-- up the tree from the leaves, and thereby cut branches.+-- All the tricky things are done in the function 'combine'.+backjump :: Tree a -> Tree (Maybe (ConflictSet QPN))+backjump = snd . cata go+  where+    go (FailF c fr) = (Just c, Fail c fr)+    go (DoneF rdm ) = (Nothing, Done rdm)+    go (PChoiceF qpn _   ts) = (c, PChoice qpn c   (P.fromList ts'))+      where+        ~(c, ts') = combine (P qpn) (P.toList ts) S.empty+    go (FChoiceF qfn _ b ts) = (c, FChoice qfn c b (P.fromList ts'))+      where+        ~(c, ts') = combine (F qfn) (P.toList ts) S.empty+    go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts'))+      where+        ~(c, ts') = combine (S qsn) (P.toList ts) S.empty+    go (GoalChoiceF      ts) = (c, GoalChoice      (P.fromList ts'))+      where+        ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts+        c          = case cs of []    -> Nothing+                                d : _ -> d++-- | The 'combine' function is at the heart of backjumping. It takes+-- the variable we're currently considering, and a list of children+-- annotated with their respective conflict sets, and an accumulator+-- for the result conflict set. It returns a combined conflict set+-- for the parent node, and a (potentially shortened) list of children+-- with the annotations removed.+--+-- It is *essential* that we produce the results as early as possible.+-- In particular, we have to produce the list of children prior to+-- traversing the entire list -- otherwise we lose the desired behaviour+-- of being able to traverse the tree from left to right incrementally.+--+-- We can shorten the list of children if we find an individual conflict+-- set that does not contain the current variable. In this case, we can+-- just lift the conflict set to the current level, because the current+-- level cannot possibly have contributed to this conflict, so no other+-- choice at the current level would avoid the conflict.+--+-- If any of the children might contain a successful solution+-- (indicated by Nothing), then Nothing will be the combined+-- conflict set. If all children contain conflict sets, we can+-- take the union as the combined conflict set.+combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] ->+           ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)])+combine _   []                      c = (Just c, [])+combine var ((k, (     d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $+                                        case d of+                                          Just e | not (var `S.member` e) -> (Just e, [])+                                                 | otherwise              -> combine var xs (e `S.union` c)+                                          Nothing                         -> (Nothing, snd $ combine var xs S.empty)++-- | Naive backtracking exploration of the search tree. This will yield correct+-- assignments only once the tree itself is validated.+explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap))+explore = cata go+  where+    go (FailF _ _)           _           = A.empty+    go (DoneF rdm)           a           = pure (a, rdm)+    go (PChoiceF qpn _   ts) (A pa fa sa)   =+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice+      ts+    go (FChoiceF qfn _ _ ts) (A pa fa sa)   =+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice+      ts+    go (SChoiceF qsn _ _ ts) (A pa fa sa)   =+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice+      ts+    go (GoalChoiceF      ts) a           =+      casePSQ ts A.empty                      -- empty goal choice is an internal error+        (\ _k v _xs -> v a)                   -- commit to the first goal choice++-- | Version of 'explore' that returns a 'Log'.+exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap))+exploreLog = cata go+  where+    go (FailF c fr)          _           = failWith (Failure c fr)+    go (DoneF rdm)           a           = succeedWith Success (a, rdm)+    go (PChoiceF qpn c   ts) (A pa fa sa)   =+      backjumpInfo c $+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> tryWith (TryP (PI qpn k)) $     -- log and ...+                    r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice+      ts+    go (FChoiceF qfn c _ ts) (A pa fa sa)   =+      backjumpInfo c $+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> tryWith (TryF qfn k) $          -- log and ...+                    r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice+      ts+    go (SChoiceF qsn c _ ts) (A pa fa sa)   =+      backjumpInfo c $+      asum $                                      -- try children in order,+      P.mapWithKey                                -- when descending ...+        (\ k r -> tryWith (TryS qsn k) $          -- log and ...+                    r (A pa fa (M.insert qsn k sa))) -- record the pkg choice+      ts+    go (GoalChoiceF      ts) a           =+      casePSQ ts+        (failWith (Failure S.empty EmptyGoalChoice))   -- empty goal choice is an internal error+        (\ k v _xs -> continueWith (Next (close k)) (v a))     -- commit to the first goal choice++-- | Add in information about pruned trees.+--+-- TODO: This isn't quite optimal, because we do not merely report the shape of the+-- tree, but rather make assumptions about where that shape originated from. It'd be+-- better if the pruning itself would leave information that we could pick up at this+-- point.+backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a+backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'!+                           Nothing -> A.empty+                           Just cs -> failWith (Failure cs Backjump)++-- | Interface.+exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap)+exploreTree t = explore t (A M.empty M.empty M.empty)++-- | Interface.+exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap)+exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty)

+ Distribution/Client/Dependency/Modular/Flag.hs view

@@ -0,0 +1,69 @@+module Distribution.Client.Dependency.Modular.Flag where++import Data.Map as M+import Prelude hiding (pi)++import Distribution.PackageDescription hiding (Flag) -- from Cabal++import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Types (OptionalStanza(..))++-- | Flag name. Consists of a package instance and the flag identifier itself.+data FN qpn = FN (PI qpn) Flag+  deriving (Eq, Ord, Show)++-- | Extract the package name from a flag name.+getPN :: FN qpn -> qpn+getPN (FN (PI qpn _) _) = qpn++instance Functor FN where+  fmap f (FN x y) = FN (fmap f x) y++-- | Flag identifier. Just a string.+type Flag = FlagName++unFlag :: Flag -> String+unFlag (FlagName fn) = fn++-- | Flag default. Just a bool.+type FDefault = Bool++-- | Flag defaults.+type FlagDefaults = Map Flag FDefault++-- | Qualified flag name.+type QFN = FN QPN++-- | Stanza name. Paired with a package name, much like a flag.+data SN qpn = SN (PI qpn) OptionalStanza+  deriving (Eq, Ord, Show)++instance Functor SN where+  fmap f (SN x y) = SN (fmap f x) y++-- | Qualified stanza name.+type QSN = SN QPN++unStanza :: OptionalStanza -> String+unStanza TestStanzas  = "test"+unStanza BenchStanzas = "bench"++showQFNBool :: QFN -> Bool -> String+showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b++showQSNBool :: QSN -> Bool -> String+showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b++showFBool :: FN qpn -> Bool -> String+showFBool (FN _ f) True  = "+" ++ unFlag f+showFBool (FN _ f) False = "-" ++ unFlag f++showSBool :: SN qpn -> Bool -> String+showSBool (SN _ s) True  = "*" ++ unStanza s+showSBool (SN _ s) False = "!" ++ unStanza s++showQFN :: QFN -> String+showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f++showQSN :: QSN -> String+showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f

+ Distribution/Client/Dependency/Modular/Index.hs view

@@ -0,0 +1,33 @@+module Distribution.Client.Dependency.Modular.Index where++import Data.List as L+import Data.Map as M+import Prelude hiding (pi)++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree++-- | An index contains information about package instances. This is a nested+-- dictionary. Package names are mapped to instances, which in turn is mapped+-- to info.+type Index = Map PN (Map I PInfo)++-- | Info associated with a package instance.+-- Currently, dependencies, flags, encapsulations 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 PN) FlagDefaults Encaps (Maybe FailReason)+  deriving (Show)++-- | Encapsulations. A list of package names.+type Encaps = [PN]++mkIndex :: [(PN, I, PInfo)] -> Index+mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))++groupMap :: Ord a => [(a, b)] -> Map a [b]+groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)

+ Distribution/Client/Dependency/Modular/IndexConversion.hs view

@@ -0,0 +1,185 @@+module Distribution.Client.Dependency.Modular.IndexConversion where++import Data.List as L+import Data.Map as M+import Data.Maybe+import Prelude hiding (pi)++import qualified Distribution.Client.PackageIndex as CI+import Distribution.Client.Types+import Distribution.Compiler+import Distribution.InstalledPackageInfo as IPI+import Distribution.Package                          -- from Cabal+import Distribution.PackageDescription as PD         -- from Cabal+import qualified Distribution.Simple.PackageIndex as SI+import Distribution.Simple.Utils (equating)+import Distribution.System++import Distribution.Client.Dependency.Modular.Dependency as D+import Distribution.Client.Dependency.Modular.Flag as F+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree+import Distribution.Client.Dependency.Modular.Version++-- | Convert both the installed package index and the source package+-- index into one uniform solver index.+--+-- We use 'allPackagesByName' for the installed package index because+-- that returns us several instances of the same package and version+-- in order of preference. This allows us in principle to "shadow"+-- packages if there are several installed packages of the same version.+-- There are currently some shortcomings in both GHC and Cabal in+-- resolving these situations. However, the right thing to do is to+-- fix the problem there, so for now, shadowing is only activated if+-- explicitly requested.+convPIs :: OS -> Arch -> CompilerId -> Bool ->+           SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index+convPIs os arch cid sip iidx sidx =+  mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx)++-- | Convert a Cabal installed package index to the simpler,+-- more uniform index format of the solver.+convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)]+convIPI' sip idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx+  where+    -- group installed packages by version+    versioned = L.map (groupBy (equating packageVersion))+    -- apply shadowing whenever there are multple installed packages with+    -- the same version+    combine f pkgs = [ g (f p) | pbn <- pkgs, pbv <- pbn,+                                 (g, p) <- zip (id : repeat shadow) pbv ]+    -- shadowing is recorded in the package info+    shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))+    shadow x                                     = x++convIPI :: Bool -> SI.PackageIndex -> Index+convIPI sip = mkIndex . convIPI' sip++-- | Convert a single installed package into the solver-specific format.+convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)+convIP idx ipi =+  let ipid = installedPackageId ipi+      i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)+      pn = pkgName (sourcePackageId ipi)+  in  case mapM (convIPId pn idx) (IPI.depends ipi) of+        Nothing  -> (pn, i, PInfo [] M.empty [] (Just Broken))+        Just fds -> (pn, i, PInfo fds M.empty [] Nothing)+-- TODO: Installed packages should also store their encapsulations!++-- | Convert dependencies specified by an installed package id into+-- flagged dependencies of the solver.+--+-- 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.PackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN)+convIPId pn' idx ipid =+  case SI.lookupInstalledPackageId idx ipid of+    Nothing  -> Nothing+    Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)+                    pn = pkgName (sourcePackageId ipi)+                in  Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))))++-- | Convert a cabal-install source package index to the simpler,+-- more uniform index format of the solver.+convSPI' :: OS -> Arch -> CompilerId ->+            CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]+convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages++convSPI :: OS -> Arch -> CompilerId ->+           CI.PackageIndex SourcePackage -> Index+convSPI os arch cid = mkIndex . convSPI' os arch cid++-- | Convert a single source package into the solver-specific format.+convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo)+convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) =+  let i = I pv InRepo+  in  (pn, i, convGPD os arch cid (PI pn i) gpd)++-- We do not use 'flattenPackageDescription' or 'finalizePackageDescription'+-- from 'Distribution.PackageDescription.Configuration' here, because we+-- want to keep the condition tree, but simplify much of the test.++-- | Convert a generic package description to a solver-specific 'PInfo'.+--+-- TODO: We currently just take all dependencies from all specified library,+-- executable and test components. This does not quite seem fair.+convGPD :: OS -> Arch -> CompilerId ->+           PI PN -> GenericPackageDescription -> PInfo+convGPD os arch cid pi+        (GenericPackageDescription _ flags libs exes tests benchs) =+  let+    fds = flagDefaults flags+  in+    PInfo+      (maybe []    (convCondTree os arch cid pi fds (const True)          ) libs    +++       concatMap   (convCondTree os arch cid pi fds (const True)     . snd) exes    +++      (prefix (Stanza (SN pi TestStanzas))+        (concatMap (convCondTree os arch cid pi fds (const True)     . snd) tests)) +++      (prefix (Stanza (SN pi BenchStanzas))+        (concatMap (convCondTree os arch cid pi fds (const True)     . snd) benchs)))+      fds+      [] -- TODO: add encaps+      Nothing++prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> FlaggedDeps qpn -> FlaggedDeps qpn+prefix _ []  = []+prefix f fds = [f fds]++-- | Convert flag information.+flagDefaults :: [PD.Flag] -> FlagDefaults+flagDefaults = M.fromList . L.map (\ (MkFlag fn _ b _) -> (fn, b))++-- | Convert condition trees to flagged dependencies.+convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagDefaults ->+                (a -> Bool) -> -- how to detect if a branch is active+                CondTree ConfVar [Dependency] a -> FlaggedDeps PN+convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches)+  | p info    = L.map (D.Simple . convDep pn) ds  -- unconditional dependencies+              ++ concatMap (convBranch os arch cid pi fds p) branches+  | otherwise = []++-- | Branch interpreter.+--+-- Here, we try to simplify one of Cabal's condition tree branches into the+-- solver's flagged dependency format, which is weaker. Condition trees can+-- contain complex logical expression composed from flag choices and special+-- flags (such as architecture, or compiler flavour). We try to evaluate the+-- special flags and subsequently simplify to a tree that only depends on+-- simple flag choices.+convBranch :: OS -> Arch -> CompilerId ->+              PI PN -> FlagDefaults ->+              (a -> Bool) -> -- how to detect if a branch is active+              (Condition ConfVar,+               CondTree ConfVar [Dependency] a,+               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN+convBranch os arch cid@(CompilerId cf cv) pi fds p (c', t', mf') =+  go c' (          convCondTree os arch cid pi fds p   t')+        (maybe [] (convCondTree os arch cid pi fds p) mf')+  where+    go :: Condition ConfVar ->+          FlaggedDeps PN -> FlaggedDeps 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 = [Flagged (FN pi fn) (fds ! fn) t f]+    go (Var (OS os')) t f+      | os == os'      = t+      | otherwise      = f+    go (Var (Arch arch')) t f+      | arch == arch'  = t+      | otherwise      = f+    go (Var (Impl cf' cvr')) t f+      | cf == cf' && checkVR cvr' cv = t+      | otherwise      = f++-- | Convert a Cabal dependency to a solver-specific dependency.+convDep :: PN -> Dependency -> Dep PN+convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])])++-- | Convert a Cabal package identifier to a solver-specific dependency.+convPI :: PN -> PackageIdentifier -> Dep PN+convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (P pn') [])])

+ Distribution/Client/Dependency/Modular/Log.hs view

@@ -0,0 +1,96 @@+module Distribution.Client.Dependency.Modular.Log where++import Control.Applicative+import Data.List as L+import Data.Set as S++import Distribution.Client.Dependency.Types -- from Cabal++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Message+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree (FailReason(..))++-- | The 'Log' datatype.+--+-- Represents the progress of a computation lazily.+--+-- Parameterized over the type of actual messages and the final result.+type Log m a = Progress m () a++runLog :: Log m a -> ([m], Maybe a)+runLog (Done x)       = ([], Just x)+runLog (Fail _)       = ([], Nothing)+runLog (Step m p)     = let+                          (ms, r) = runLog p+                        in+                          (m : ms, r)++-- | 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 :: Maybe Int -> Log Message a -> Progress String String a+logToProgress mbj l = let+                        (ms, s) = runLog l+                        (es, e) = proc 0 ms -- catch first error (always)+                        (ns, t) = case mbj of+                                    Nothing -> (ms, Nothing)+                                    Just n  -> proc n ms+                        -- prefer first error over later error+                        r       = case t of+                                    Nothing -> case s of+                                                 Nothing -> e+                                                 Just _  -> Nothing+                                    Just _  -> e+                      in go es -- trace for first error+                            (showMessages (const True) True ns) -- shortened run+                            r s+  where+    proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))+    proc _ []                             = ([], Nothing)+    proc n (   Failure cs Backjump  : xs@(Leave : Failure cs' Backjump : _))+      | cs == cs'                         = proc n xs -- repeated backjumps count as one+    proc 0 (   Failure cs Backjump  : _ ) = ([], Just cs)+    proc n (x@(Failure _  Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)+    proc n (x                       : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc  n      xs)++    -- The order of arguments is important! In particular 's' must not be evaluated+    -- unless absolutely necessary. It contains the final result, and if we shortcut+    -- with an error due to backjumping, evaluating 's' would still require traversing+    -- the entire tree.+    go ms (x : xs) r         s        = Step x (go ms xs r s)+    go ms []       (Just cs) _        = Fail ("Could not resolve dependencies:\n" +++                                        unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))+    go _  []       _         (Just s) = Done s+    go _  []       _         _        = Fail ("Could not resolve dependencies.") -- should not happen++logToProgress' :: Log Message a -> Progress String String a+logToProgress' l = let+                    (ms, r) = runLog l+                    xs      = showMessages (const True) True ms+                  in go xs r+  where+    go [x]    Nothing  = Fail x+    go []     Nothing  = Fail ""+    go []     (Just r) = Done r+    go (x:xs) r        = Step x (go xs r)+++runLogIO :: Log Message a -> IO (Maybe a)+runLogIO x =+  do+    let (ms, r) = runLog x+    putStr (unlines $ showMessages (const True) True ms)+    return r++failWith :: m -> Log m a+failWith m = Step m (Fail ())++succeedWith :: m -> a -> Log m a+succeedWith m x = Step m (Done x)++continueWith :: m -> Log m a -> Log m a+continueWith = Step++tryWith :: Message -> Log Message a -> Log Message a+tryWith m x = Step m (Step Enter x) <|> failWith Leave

+ Distribution/Client/Dependency/Modular/Message.hs view

@@ -0,0 +1,97 @@+module Distribution.Client.Dependency.Modular.Message where++import qualified Data.List as L+import Prelude hiding (pi)++import Distribution.Text -- from Cabal++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree++data Message =+    Enter           -- ^ increase indentation level+  | Leave           -- ^ decrease indentation level+  | TryP (PI QPN)+  | TryF QFN Bool+  | TryS QSN Bool+  | Next (Goal QPN)+  | Success+  | Failure (ConflictSet QPN) FailReason++-- | 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 -> [Message] -> [String]+showMessages p sl = go [] 0+  where+    go :: [Var QPN] -> Int -> [Message] -> [String]+    go _ _ []                            = []+    -- complex patterns+    go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms+    go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)+    go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)+    go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (P qpn : v) l ms)+    go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms+    -- standard display+    go v l (Enter                  : ms) = go v          (l+1) ms+    go v l (Leave                  : ms) = go (drop 1 v) (l-1) ms+    go v l (TryP pi@(PI qpn _)     : ms) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi) (go (P qpn : v) l ms)+    go v l (TryF qfn b             : ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms)+    go v l (TryS qsn b             : ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms)+    go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (P qpn : v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)+    go v l (Next _                 : ms) = go v l ms -- ignore flag goals in the log+    go v l (Success                : ms) = (atLevel v l $ "done") (go v l ms)+    go v l (Failure c fr           : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms)++    -- special handler for many subsequent package rejections+    goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String]+    goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : 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: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms)++    -- write a message, but only if it's relevant; we can also enable or disable the display of the current level+    atLevel v l x xs+      | sl && p v = let s = show l+                    in  ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs+      | p v       = x : xs+      | otherwise = xs++showGRs :: QGoalReasons -> String+showGRs (gr : _) = showGR gr+showGRs []       = ""++showGR :: GoalReason QPN -> 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 ++ ")"++showFR :: ConflictSet QPN -> FailReason -> String+showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)"+showFR _ (Conflicting ds)               = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"+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)"+showFR _ Broken                         = " (package is broken)"+showFR _ (GlobalConstraintVersion vr)   = " (global constraint requires " ++ display vr ++ ")"+showFR _ GlobalConstraintInstalled      = " (global constraint requires installed instance)"+showFR _ GlobalConstraintSource         = " (global constraint requires source instance)"+showFR _ GlobalConstraintFlag           = " (global constraint requires opposite flag selection)"+showFR _ (BuildFailureNotInIndex pn)    = " (unknown package: " ++ display pn ++ ")"+showFR c Backjump                       = " (backjumping, conflict set: " ++ showCS c ++ ")"+-- The following are internal failures. They should not occur. In the+-- interest of not crashing unnecessarily, we still just print an error+-- message though.+showFR _ (MalformedFlagChoice qfn)      = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"+showFR _ (MalformedStanzaChoice qsn)    = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"+showFR _ EmptyGoalChoice                = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"

+ Distribution/Client/Dependency/Modular/PSQ.hs view

@@ -0,0 +1,102 @@+module Distribution.Client.Dependency.Modular.PSQ where++-- Priority search queues.+--+-- I am not yet sure what exactly is needed. But we need a datastructure with+-- key-based lookup that can be sorted. We're using a sequence right now with+-- (inefficiently implemented) lookup, because I think that queue-based+-- opertions and sorting turn out to be more efficiency-critical in practice.++import Control.Applicative+import Data.Foldable+import Data.Function+import Data.List as S hiding (foldr)+import Data.Traversable+import Prelude hiding (foldr)++newtype PSQ k v = PSQ [(k, v)]+  deriving (Eq, Show)++instance Functor (PSQ k) where+  fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)++instance Foldable (PSQ k) where+  foldr op e (PSQ xs) = foldr op e (fmap snd xs)++instance Traversable (PSQ k) where+  traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs++keys :: PSQ k v -> [k]+keys (PSQ xs) = fmap fst xs++lookup :: Eq k => k -> PSQ k v -> Maybe v+lookup k (PSQ xs) = S.lookup k xs++map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2+map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)++mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v+mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs)++mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b+mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)++mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b+mapWithKeyState p (PSQ xs) s0 =+  PSQ (foldr (\ (k, v) r s -> case p s k v of+                                (w, n) -> (k, w) : (r n))+             (const []) xs s0)++delete :: Eq k => k -> PSQ k a -> PSQ k a+delete k (PSQ xs) = PSQ (snd (partition ((== k) . fst) xs))++fromList :: [(k, a)] -> PSQ k a+fromList = PSQ++cons :: k -> a -> PSQ k a -> PSQ k a+cons k x (PSQ xs) = PSQ ((k, x) : xs)++snoc :: PSQ k a -> k -> a -> PSQ k a+snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])++casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r+casePSQ (PSQ xs) n c =+  case xs of+    []          -> n+    (k, v) : ys -> c k v (PSQ ys)++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)))++sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a+sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)++sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a+sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)++filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)++filter :: (a -> Bool) -> PSQ k a -> PSQ k a+filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)++length :: PSQ k a -> Int+length (PSQ xs) = S.length xs++-- | "Lazy length".+--+-- Only approximates the length, but doesn't force the list.+llength :: PSQ k a -> Int+llength (PSQ [])       = 0+llength (PSQ (_:[]))   = 1+llength (PSQ (_:_:[])) = 2+llength (PSQ _)        = 3++null :: PSQ k a -> Bool+null (PSQ xs) = S.null xs++toList :: PSQ k a -> [(k, a)]+toList (PSQ xs) = xs

+ Distribution/Client/Dependency/Modular/Package.hs view

@@ -0,0 +1,113 @@+module Distribution.Client.Dependency.Modular.Package+  (module Distribution.Client.Dependency.Modular.Package,+   module Distribution.Package) where++import Data.List as L+import Data.Map as M++import Distribution.Package -- from Cabal+import Distribution.Text    -- from Cabal++import Distribution.Client.Dependency.Modular.Version++-- | A package name.+type PN = PackageName++-- | Unpacking a package name.+unPN :: PN -> String+unPN (PackageName pn) = pn++-- | Package version. A package name plus a version number.+type PV = PackageId++-- | Qualified package version.+type QPV = Q PV++-- | Package id. Currently just a black-box string.+type PId = InstalledPackageId++-- | Location. Info about whether a package is installed or not, and where+-- exactly it is located. For installed packages, uniquely identifies the+-- package instance via its 'PId'.+--+-- TODO: More information is needed about the repo.+data Loc = Inst PId | InRepo+  deriving (Eq, Ord, Show)++-- | Instance. A version number and a location.+data I = I Ver Loc+  deriving (Eq, Ord, Show)++-- | String representation of an instance.+showI :: I -> String+showI (I v InRepo)   = showVer v+showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i+  where+    -- A hack to extract the beginning of the package ABI hash+    shortId = snip (splitAt 4) (++ "...") .+              snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)+    snip p f xs = case p xs of+                    (ys, zs) -> (if L.null zs then id else f) ys++-- | Package instance. A package name and an instance.+data PI qpn = PI qpn I+  deriving (Eq, Ord, Show)++-- | String representation of a package instance.+showPI :: PI QPN -> String+showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i++-- | Checks if a package instance corresponds to an installed package.+instPI :: PI qpn -> Bool+instPI (PI _ (I _ (Inst _))) = True+instPI _                     = False++instI :: I -> Bool+instI (I _ (Inst _)) = True+instI _              = False++instance Functor PI where+  fmap f (PI x y) = PI (f x) y++-- | Package path. (Stored in "reverse" order.)+type PP = [PN]++-- | String representation of a package path.+showPP :: PP -> String+showPP = intercalate "." . L.map display . reverse+++-- | A qualified entity. Pairs a package path with the entity.+data Q a = Q PP a+  deriving (Eq, Ord, Show)++-- | Standard string representation of a qualified entity.+showQ :: (a -> String) -> (Q a -> String)+showQ showa (Q [] x) = showa x+showQ showa (Q pp x) = showPP pp ++ "." ++ showa x++-- | Qualified package name.+type QPN = Q PN++-- | String representation of a qualified package path.+showQPN :: QPN -> String+showQPN = showQ display++-- | The scope associates every package with a path. The convention is that packages+-- not in the data structure have an empty path associated with them.+type Scope = Map PN PP++-- | An empty scope structure, for initialization.+emptyScope :: Scope+emptyScope = M.empty++-- | Create artificial parents for each of the package names, making+-- them all independent.+makeIndependent :: [PN] -> Scope+makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps)++qualify :: Scope -> PN -> QPN+qualify sc pn = Q (findWithDefault [] pn sc) pn++unQualify :: Q a -> a+unQualify (Q _ x) = x

+ Distribution/Client/Dependency/Modular/Preference.hs view

@@ -0,0 +1,258 @@+module Distribution.Client.Dependency.Modular.Preference where++-- Reordering or pruning the tree in order to prefer or make certain choices.++import qualified Data.List as L+import qualified Data.Map as M+import Data.Monoid+import Data.Ord++import Distribution.Client.Dependency.Types+  ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) )+import Distribution.Client.Types+  ( OptionalStanza(..) )++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree+import Distribution.Client.Dependency.Modular.Version++-- | Generic abstraction for strategies that just rearrange the package order.+-- Only packages that match the given predicate are reordered.+packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a+packageOrderFor p cmp = trav go+  where+    go (PChoiceF v@(Q _ pn) r cs)+      | p pn                        = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs)+      | otherwise                   = PChoiceF v r                               cs+    go x                            = x++-- | Ordering that treats preferred versions as greater than non-preferred+-- versions.+preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering+preferredVersionsOrdering vr v1 v2 =+  compare (checkVR vr v1) (checkVR vr v2)++-- | Traversal that tries to establish package preferences (not constraints).+-- Works by reordering choice nodes.+preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a+preferPackagePreferences pcs = packageOrderFor (const True) preference+  where+    preference pn i1@(I v1 _) i2@(I v2 _) =+      let PackagePreferences vr ipref = pcs pn+      in  preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically+          locationsOrdering ipref i1 i2++    -- Note that we always rank installed before uninstalled, and later+    -- versions before earlier, but we can change the priority of the+    -- two orderings.+    locationsOrdering PreferInstalled v1 v2 =+      preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2+    locationsOrdering PreferLatest v1 v2 =+      preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2++-- | Ordering that treats installed instances as greater than uninstalled ones.+preferInstalledOrdering :: I -> I -> Ordering+preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ+preferInstalledOrdering (I _ (Inst _)) _              = GT+preferInstalledOrdering _              (I _ (Inst _)) = LT+preferInstalledOrdering _              _              = EQ++-- | Compare instances by their version numbers.+preferLatestOrdering :: I -> I -> Ordering+preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2++-- | Helper function that tries to enforce a single package constraint on a+-- given instance for a P-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintP :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a+processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r+  | checkVR vr v  = r+  | otherwise     = Fail c (GlobalConstraintVersion vr)+processPackageConstraintP c i       (PackageConstraintInstalled _)  r+  | instI i       = r+  | otherwise     = Fail c GlobalConstraintInstalled+processPackageConstraintP c i       (PackageConstraintSource    _)  r+  | not (instI i) = r+  | otherwise     = Fail c GlobalConstraintSource+processPackageConstraintP _ _       _                               r = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintF :: Flag -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a+processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r =+  case L.lookup f fa of+    Nothing            -> r+    Just b | b == b'   -> r+           | otherwise -> Fail c GlobalConstraintFlag+processPackageConstraintF _ _ _  _                             r = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintS :: OptionalStanza -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a+processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r =+  if not b' && s `elem` ss then Fail c GlobalConstraintFlag+                           else r+processPackageConstraintS _ _ _  _                             r = r++-- | Traversal that tries to establish various kinds of user constraints. Works+-- by selectively disabling choices that have been ruled out by global user+-- constraints.+enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons+enforcePackageConstraints pcs = trav go+  where+    go (PChoiceF qpn@(Q _ pn)               gr    ts) =+      let c = toConflictSet (Goal (P qpn) gr)+          -- compose the transformation functions for each of the relevant constraint+          g = \ i -> foldl (\ h pc -> h . processPackageConstraintP   c i pc) id+                           (M.findWithDefault [] pn pcs)+      in PChoiceF qpn gr    (P.mapWithKey g ts)+    go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr ts) =+      let c = toConflictSet (Goal (F qfn) gr)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id+                           (M.findWithDefault [] pn pcs)+      in FChoiceF qfn gr tr (P.mapWithKey g ts)+    go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =+      let c = toConflictSet (Goal (S qsn) gr)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id+                           (M.findWithDefault [] pn pcs)+      in SChoiceF qsn gr tr (P.mapWithKey g ts)+    go x = x++-- | Prefer installed packages over non-installed packages, generally.+-- All installed packages or non-installed packages are treated as+-- equivalent.+preferInstalled :: Tree a -> Tree a+preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering)++-- | Prefer packages with higher version numbers over packages with+-- lower version numbers, for certain packages.+preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a+preferLatestFor p = packageOrderFor p (const preferLatestOrdering)++-- | Prefer packages with higher version numbers over packages with+-- lower version numbers, for all packages.+preferLatest :: Tree a -> Tree a+preferLatest = preferLatestFor (const True)++-- | Require installed packages.+requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+requireInstalled p = trav go+  where+    go (PChoiceF v@(Q _ pn) i@(gr, _) cs)+      | p pn      = PChoiceF v i (P.mapWithKey installed cs)+      | otherwise = PChoiceF v i                         cs+      where+        installed (I _ (Inst _)) x = x+        installed _              _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall+    go x          = x++-- | Avoid reinstalls.+--+-- This is a tricky strategy. If a package version is installed already and the+-- same version is available from a repo, the repo version will never be chosen.+-- This would result in a reinstall (either destructively, or potentially,+-- shadowing). The old instance won't be visible or even present anymore, but+-- other packages might have depended on it.+--+-- TODO: It would be better to actually check the reverse dependencies of installed+-- packages. If they're not depended on, then reinstalling should be fine. Even if+-- they are, perhaps this should just result in trying to reinstall those other+-- packages as well. However, doing this all neatly in one pass would require to+-- change the builder, or at least to change the goal set after building.+avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+avoidReinstalls p = trav go+  where+    go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)+      | p pn      = PChoiceF qpn i disableReinstalls+      | otherwise = PChoiceF qpn i cs+      where+        disableReinstalls =+          let installed = [ v | (I v (Inst _), _) <- toList cs ]+          in  P.mapWithKey (notReinstall installed) cs++        notReinstall vs (I v InRepo) _+          | v `elem` vs                = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall+        notReinstall _  _            x = x+    go x          = x++-- | Always choose the first goal in the list next, abandoning all+-- other choices.+--+-- This is unnecessary for the default search strategy, because+-- it descends only into the first goal choice anyway,+-- but may still make sense to just reduce the tree size a bit.+firstGoal :: Tree a -> Tree a+firstGoal = trav go+  where+    go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t)+    go x                = x+    -- Note that we keep empty choice nodes, because they mean success.++-- | Transformation that tries to make a decision on base as early as+-- possible. In nearly all cases, there's a single choice for the base+-- package. Also, fixing base early should lead to better error messages.+preferBaseGoalChoice :: Tree a -> Tree a+preferBaseGoalChoice = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)+    go x                = x++    preferBase :: OpenGoal -> OpenGoal -> Ordering+    preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT+    preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT+    preferBase _ _                                                           = EQ++-- | Transformation that sorts choice nodes so that+-- child nodes with a small branching degree are preferred. As a+-- special case, choices with 0 branches will be preferred (as they+-- are immediately considered inconsistent), and choices with 1+-- branch will also be preferred (as they don't involve choice).+preferEasyGoalChoices :: Tree a -> Tree a+preferEasyGoalChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs)+    go x                = x++-- | Transformation that tries to avoid making inconsequential+-- flag choices early.+deferDefaultFlagChoices :: Tree a -> Tree a+deferDefaultFlagChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs)+    go x                = x++    defer :: Tree a -> Tree a -> Ordering+    defer (FChoice _ _ True _) _ = GT+    defer _ (FChoice _ _ True _) = LT+    defer _ _                    = EQ++-- | Variant of 'preferEasyGoalChoices'.+--+-- Only approximates the number of choices in the branches. Less accurate,+-- more efficient.+lpreferEasyGoalChoices :: Tree a -> Tree a+lpreferEasyGoalChoices = trav go+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs)+    go x                = x++-- | Variant of 'preferEasyGoalChoices'.+--+-- I first thought that using a paramorphism might be faster here,+-- but it doesn't seem to make any difference.+preferEasyGoalChoices' :: Tree a -> Tree a+preferEasyGoalChoices' = para (inn . go)+  where+    go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))+    go x                = fmap fst x+

+ Distribution/Client/Dependency/Modular/Solver.hs view

@@ -0,0 +1,52 @@+module Distribution.Client.Dependency.Modular.Solver where++import Data.Map as M++import Distribution.Client.Dependency.Types++import Distribution.Client.Dependency.Modular.Assignment+import Distribution.Client.Dependency.Modular.Builder+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Explore+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Log+import Distribution.Client.Dependency.Modular.Message+import Distribution.Client.Dependency.Modular.Package+import qualified Distribution.Client.Dependency.Modular.Preference as P+import Distribution.Client.Dependency.Modular.Validate++-- | Various options for the modular solver.+data SolverConfig = SolverConfig {+  preferEasyGoalChoices :: Bool,+  independentGoals      :: Bool,+  avoidReinstalls       :: Bool,+  shadowPkgs            :: Bool,+  maxBackjumps          :: Maybe Int+}++solve :: SolverConfig ->   -- solver parameters+         Index ->          -- all available packages as an index+         (PN -> PackagePreferences) -> -- preferences+         Map PN [PackageConstraint] -> -- global constraints+         [PN] ->                       -- global goals+         Log Message (Assignment, RevDepMap)+solve sc idx userPrefs userConstraints userGoals =+  explorePhase     $+  heuristicsPhase  $+  preferencesPhase $+  validationPhase  $+  prunePhase       $+  buildPhase+  where+    explorePhase     = exploreTreeLog . backjump+    heuristicsPhase  = if preferEasyGoalChoices sc+                         then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices+                         else P.preferBaseGoalChoice+    preferencesPhase = P.preferPackagePreferences userPrefs+    validationPhase  = P.enforcePackageConstraints userConstraints .+                       validateTree idx+    prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .+                       -- packages that can never be "upgraded":+                       P.requireInstalled (`elem` [PackageName "base",+                                                   PackageName "ghc-prim"])+    buildPhase       = buildTree idx (independentGoals sc) userGoals

+ Distribution/Client/Dependency/Modular/Tree.hs view

@@ -0,0 +1,146 @@+module Distribution.Client.Dependency.Modular.Tree where++import Control.Applicative+import Control.Monad hiding (mapM)+import Data.Foldable+import Data.Traversable+import Prelude hiding (foldr, mapM)++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Version++-- | Type of the search tree. Inlining the choice nodes for now.+data Tree a =+    PChoice     QPN a      (PSQ I        (Tree a))+  | FChoice     QFN a Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial+  | SChoice     QSN a Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial+  | GoalChoice             (PSQ OpenGoal (Tree a)) -- PSQ should never be empty+  | Done        RevDepMap+  | Fail        (ConflictSet QPN) FailReason+  deriving (Eq, Show)+  -- Above, a choice is called trivial if it clearly does not matter. The+  -- special case of triviality we actually consider is if there are no new+  -- dependencies introduced by this node.++instance Functor Tree where+  fmap  f (PChoice qpn i   xs) = PChoice qpn (f i)   (fmap (fmap f) xs)+  fmap  f (FChoice qfn i b xs) = FChoice qfn (f i) b (fmap (fmap f) xs)+  fmap  f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)+  fmap  f (GoalChoice      xs) = GoalChoice          (fmap (fmap f) xs)+  fmap _f (Done    rdm       ) = Done    rdm+  fmap _f (Fail    cs fr     ) = Fail    cs fr++data FailReason = InconsistentInitialConstraints+                | Conflicting [Dep QPN]+                | CannotInstall+                | CannotReinstall+                | Shadowed+                | Broken+                | GlobalConstraintVersion VR+                | GlobalConstraintInstalled+                | GlobalConstraintSource+                | GlobalConstraintFlag+                | BuildFailureNotInIndex PN+                | MalformedFlagChoice QFN+                | MalformedStanzaChoice QSN+                | EmptyGoalChoice+                | Backjump+  deriving (Eq, Show)++-- | Functor for the tree type.+data TreeF a b =+    PChoiceF    QPN a      (PSQ I        b)+  | FChoiceF    QFN a Bool (PSQ Bool     b)+  | SChoiceF    QSN a Bool (PSQ Bool     b)+  | GoalChoiceF            (PSQ OpenGoal b)+  | DoneF       RevDepMap+  | FailF       (ConflictSet QPN) FailReason++out :: Tree a -> TreeF a (Tree a)+out (PChoice    p i   ts) = PChoiceF    p i   ts+out (FChoice    p i b ts) = FChoiceF    p i b ts+out (SChoice    p i b ts) = SChoiceF    p i b ts+out (GoalChoice       ts) = GoalChoiceF       ts+out (Done       x       ) = DoneF       x+out (Fail       c x     ) = FailF       c x++inn :: TreeF a (Tree a) -> Tree a+inn (PChoiceF    p i   ts) = PChoice    p i   ts+inn (FChoiceF    p i b ts) = FChoice    p i b ts+inn (SChoiceF    p i b ts) = SChoice    p i b ts+inn (GoalChoiceF       ts) = GoalChoice       ts+inn (DoneF       x       ) = Done       x+inn (FailF       c x     ) = Fail       c x++instance Functor (TreeF a) where+  fmap f (PChoiceF    p i   ts) = PChoiceF    p i   (fmap f ts)+  fmap f (FChoiceF    p i b ts) = FChoiceF    p i b (fmap f ts)+  fmap f (SChoiceF    p i b ts) = SChoiceF    p i b (fmap f ts)+  fmap f (GoalChoiceF       ts) = GoalChoiceF       (fmap f ts)+  fmap _ (DoneF       x       ) = DoneF       x+  fmap _ (FailF       c x     ) = FailF       c x++instance Foldable (TreeF a) where+  foldr op e (PChoiceF    _ _   ts) = foldr op e ts+  foldr op e (FChoiceF    _ _ _ ts) = foldr op e ts+  foldr op e (SChoiceF    _ _ _ ts) = foldr op e ts+  foldr op e (GoalChoiceF       ts) = foldr op e ts+  foldr _  e (DoneF       _       ) = e+  foldr _  e (FailF       _ _     ) = e++instance Traversable (TreeF a) where+  traverse f (PChoiceF    p i   ts) = PChoiceF    <$> pure p <*> pure i <*>            traverse f ts+  traverse f (FChoiceF    p i b ts) = FChoiceF    <$> pure p <*> pure i <*> pure b <*> traverse f ts+  traverse f (SChoiceF    p i b ts) = SChoiceF    <$> pure p <*> pure i <*> pure b <*> traverse f ts+  traverse f (GoalChoiceF       ts) = GoalChoiceF <$>                                  traverse f ts+  traverse _ (DoneF       x       ) = DoneF       <$> pure x+  traverse _ (FailF       c x     ) = FailF       <$> pure c <*> pure x++-- | Determines whether a tree is active, i.e., isn't a failure node.+active :: Tree a -> Bool+active (Fail _ _) = False+active _          = True++-- | Determines how many active choices are available in a node. Note that we+-- count goal choices as having one choice, always.+choices :: Tree a -> Int+choices (PChoice    _ _   ts) = P.length (P.filter active ts)+choices (FChoice    _ _ _ ts) = P.length (P.filter active ts)+choices (SChoice    _ _ _ ts) = P.length (P.filter active ts)+choices (GoalChoice       _ ) = 1+choices (Done       _       ) = 1+choices (Fail       _ _     ) = 0++-- | Variant of 'choices' that only approximates the number of choices,+-- using 'llength'.+lchoices :: Tree a -> Int+lchoices (PChoice    _ _   ts) = P.llength (P.filter active ts)+lchoices (FChoice    _ _ _ ts) = P.llength (P.filter active ts)+lchoices (SChoice    _ _ _ ts) = P.llength (P.filter active ts)+lchoices (GoalChoice       _ ) = 1+lchoices (Done       _       ) = 1+lchoices (Fail       _ _     ) = 0++-- | Catamorphism on trees.+cata :: (TreeF a b -> b) -> Tree a -> b+cata phi x = (phi . fmap (cata phi) . out) x++trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b+trav psi x = cata (inn . psi) x++-- | Paramorphism on trees.+para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b+para phi = phi . fmap (\ x -> (para phi x, x)) . out++cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b+cataM phi = phi <=< mapM (cataM phi) <=< return . out++-- | Anamorphism on trees.+ana :: (b -> TreeF a b) -> b -> Tree a+ana psi = inn . fmap (ana psi) . psi++anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a)+anaM psi = return . inn <=< mapM (anaM psi) <=< psi

+ Distribution/Client/Dependency/Modular/Validate.hs view

@@ -0,0 +1,232 @@+module Distribution.Client.Dependency.Modular.Validate where++-- Validation of the tree.+--+-- The task here is to make sure all constraints hold. After validation, any+-- assignment returned by exploration of the tree should be a complete valid+-- assignment, i.e., actually constitute a solution.++import Control.Applicative+import Control.Monad.Reader hiding (sequence)+import Data.List as L+import Data.Map as M+import Data.Traversable+import Prelude hiding (sequence)++import Distribution.Client.Dependency.Modular.Assignment+import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Index+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.Tree++-- 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 precondiditions are fulfilled ACTIVE. We maintain a set+-- of currently active constraints that we pass down the node.+--+-- We aim at detecting inconsistent states as early as possible.+--+-- Whenever we make a choice, there are two things that need to happen:+--+--   (1) We must check that the choice is consistent with the currently+--       active constraints.+--+--   (2) The choice increases the set of active constraints. For the new+--       active constraints, we must check that they are consistent with+--       the current state.+--+-- We can actually merge (1) and (2) by saying the the current choice is+-- a new active constraint, fixing the choice.+--+-- If a test fails, we have detected an inconsistent state. We can+-- disable the current subtree and do not have to traverse it any further.+--+-- We need a good way to represent the current state, i.e., the current+-- set of active constraints. Since the main situation where we have to+-- search in it is (1), it seems best to store the state by package: for+-- every package, we store which versions are still allowed. If for any+-- package, we have inconsistent active constraints, we can also stop.+-- This is a particular way to read task (2):+--+--   (2, weak) We only check if the new constraints are consistent with+--       the choices we've already made, and add them to the active set.+--+--   (2, strong) We check if the new constraints are consistent with the+--       choices we've already made, and the constraints we already have.+--+-- It currently seems as if we're implementing the weak variant. However,+-- when used together with 'preferEasyGoalChoices', we will find an+-- inconsistent state in the very next step.+--+-- What do we do about flags?+--+-- Like for packages, we store the flag choices we have already made.+-- Now, regarding (1), we only have to test whether we've decided the+-- current flag before. Regarding (2), the interesting bit is in discovering+-- the new active constraints. To this end, we look up the constraints for+-- the package the flag belongs to, and traverse its flagged dependencies.+-- Wherever we find the flag in question, we start recording dependencies+-- underneath as new active dependencies. If we encounter other flags, we+-- check if we've chosen them already and either proceed or stop.++-- | The state needed during validation.+data ValidateState = VS {+  index :: Index,+  saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies+  pa    :: PreAssignment+}++type Validate = Reader ValidateState++validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons)+validate = cata go+  where+    go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons)++    go (PChoiceF qpn (gr,  sc)   ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)+    go (FChoiceF qfn (gr, _sc) b ts) =+      do+        -- Flag choices may occur repeatedly (because they can introduce new constraints+        -- in various places). However, subsequent choices must be consistent. We thereby+        -- collapse repeated flag choice nodes.+        PA _ pfa _ <- asks pa -- obtain current flag-preassignment+        case M.lookup qfn pfa of+          Just rb -> -- flag has already been assigned; collapse choice to the correct branch+                     case P.lookup rb ts of+                       Just t  -> goF qfn gr rb t+                       Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)+          Nothing -> -- flag choice is new, follow both branches+                     FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts)+    go (SChoiceF qsn (gr, _sc) b ts) =+      do+        -- Optional stanza choices are very similar to flag choices.+        PA _ _ psa <- asks pa -- obtain current stanza-preassignment+        case M.lookup qsn psa of+          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch+                     case P.lookup rb ts of+                       Just t  -> goS qsn gr rb t+                       Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn)+          Nothing -> -- stanza choice is new, follow both branches+                     SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn gr) ts)++    -- We don't need to do anything for goal choices or failure nodes.+    go (GoalChoiceF              ts) = GoalChoice <$> sequence ts+    go (DoneF    rdm               ) = pure (Done rdm)+    go (FailF    c fr              ) = pure (Fail c fr)++    -- What to do for package nodes ...+    goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goP qpn@(Q _pp pn) gr sc i r = do+      PA ppa pfa psa <- asks pa    -- obtain current preassignment+      idx            <- asks index -- obtain the index+      svd            <- asks saved -- obtain saved dependencies+      let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice+      let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope+      -- the new active constraints are given by the instance we have chosen,+      -- plus the dependency information we have for that instance+      let goal = Goal (P qpn) gr+      let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)+      -- We now try to extend the partial assignment with the new active constraints.+      let mnppa = extend (P qpn) ppa newactives+      -- 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 (toConflictSet goal) 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++    -- What to do for flag nodes ...+    goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goF qfn@(FN (PI qpn _i) _f) gr b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      svd <- asks saved         -- obtain saved dependencies+      -- 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.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npfa = M.insert qfn b pfa+      -- 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) gr b npfa psa qdeps+      -- As in the package case, we try to extend the partial assignment.+      case extend (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++    -- What to do for stanza nodes (similar to flag nodes) ...+    goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goS qsn@(SN (PI qpn _i) _f) gr b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      svd <- asks saved         -- obtain saved dependencies+      -- 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.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npsa = M.insert qsn b psa+      -- 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) gr b pfa npsa qdeps+      -- As in the package case, we try to extend the partial assignment.+      case extend (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++-- | 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 QPN -> [Dep QPN]+extractDeps 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+    Stanza qsn td       -> case M.lookup qsn sa of+                             Nothing    -> mzero+                             Just True  -> extractDeps 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 -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]+extractNewDeps v gr b fa sa = go+  where+    go deps = do+      d <- deps+      case d of+        Simple _             -> mzero+        Flagged qfn' _ td fd+          | v == F qfn'      -> L.map (resetGoal (Goal v gr)) $+                                if b then extractDeps fa sa td else extractDeps 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 (resetGoal (Goal v gr)) $+                                if b then extractDeps fa sa td else []+          | otherwise        -> case M.lookup qsn' sa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> []++-- | Interface.+validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons+validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))

+ Distribution/Client/Dependency/Modular/Version.hs view

@@ -0,0 +1,43 @@+module Distribution.Client.Dependency.Modular.Version where++import qualified Distribution.Version as CV -- from Cabal+import Distribution.Text -- from Cabal++-- | Preliminary type for versions.+type Ver = CV.Version++-- | String representation of a version.+showVer :: Ver -> String+showVer = display++-- | Version range. Consists of a lower and upper bound.+type VR = CV.VersionRange++-- | String representation of a version range.+showVR :: VR -> String+showVR = display++-- | Unconstrained version range.+anyVR :: VR+anyVR = CV.anyVersion++-- | Version range fixing a single version.+eqVR :: Ver -> VR+eqVR = CV.thisVersion++-- | Intersect two version ranges.+(.&&.) :: VR -> VR -> VR+(.&&.) = CV.intersectVersionRanges++-- | Simplify a version range.+simplifyVR :: VR -> VR+simplifyVR = CV.simplifyVersionRange++-- | Checking a version against a version range.+checkVR :: VR -> Ver -> Bool+checkVR = flip CV.withinRange++-- | Make a version number.+mkV :: [Int] -> Ver+mkV xs = CV.Version xs []+

Distribution/Client/Dependency/TopDown.hs view

@@ -18,11 +18,14 @@ import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints import Distribution.Client.Dependency.TopDown.Constraints          ( Satisfiable(..) )+import Distribution.Client.IndexUtils+         ( convert ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan          ( PlanPackage(..) ) import Distribution.Client.Types-         ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) )+         ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)+         , enableStanzas ) import Distribution.Client.Dependency.Types          ( DependencyResolver, PackageConstraint(..)          , PackagePreferences(..), InstalledPreference(..)@@ -31,9 +34,9 @@ import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Package-         ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName-         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion-         , PackageFixedDeps(depends) )+         ( PackageName(..), PackageId, Package(..), packageVersion, packageName+         , Dependency(Dependency), thisPackageVersion+         , simplifyDependency, PackageFixedDeps(depends) ) import Distribution.PackageDescription          ( PackageDescription(buildDepends) ) import Distribution.Client.PackageUtils@@ -41,7 +44,7 @@ import Distribution.PackageDescription.Configuration          ( finalizePackageDescription, flattenPackageDescription ) import Distribution.Version-         ( VersionRange, anyVersion, withinRange, simplifyVersionRange+         ( VersionRange, withinRange, simplifyVersionRange          , UpperBound(..), asVersionIntervals ) import Distribution.Compiler          ( CompilerId )@@ -53,7 +56,7 @@          ( display )  import Data.List-         ( foldl', maximumBy, minimumBy, nub, sort, groupBy )+         ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy ) import Data.Maybe          ( fromJust, fromMaybe, catMaybes ) import Data.Monoid@@ -105,9 +108,9 @@         (_, node') = maximumBy (bestByPref pkgname) choice   where     topSortNumber choice = case fst (head choice) of-      InstalledOnly           (InstalledPackageEx  _ i _) -> i-      AvailableOnly           (UnconfiguredPackage _ i _) -> i-      InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i+      InstalledOnly        (InstalledPackageEx  _ i _) -> i+      SourceOnly           (UnconfiguredPackage _ i _ _) -> i+      InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i      bestByPref pkgname = case packageInstalledPreference of         PreferLatest    ->@@ -115,8 +118,8 @@         PreferInstalled ->           comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))       where-        isInstalled (AvailableOnly _) = False-        isInstalled _                 = True+        isInstalled (SourceOnly _) = False+        isInstalled _              = True         isPreferred p = packageVersion p `withinRange` preferredVersions         (PackagePreferences preferredVersions packageInstalledPreference)           = pref pkgname@@ -135,7 +138,7 @@                      -> Either [Dependency] SelectedPackage  -- | (packages selected, packages discarded)-type SelectionChanges = ([SelectedPackage], [PackageIdentifier])+type SelectionChanges = ([SelectedPackage], [PackageId])  searchSpace :: ConfigurePackage             -> Constraints@@ -145,6 +148,10 @@             -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)                            SelectablePackage searchSpace configure constraints selected changes next =+  assert (Set.null (selectedSet `Set.intersection` next)) $+  assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $+  assert (next `Set.isSubsetOf` Constraints.packages constraints) $+   ChoiceNode (selected, constraints, changes)     [ [ (pkg, select name pkg)       | pkg <- PackageIndex.lookupPackageName available name ]@@ -152,15 +159,18 @@   where     available = Constraints.choices constraints +    selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))+     select name pkg = case configure available pkg of       Left missing -> Failure $ ConfigureFailed pkg                         [ (dep, Constraints.conflicting constraints dep)                         | dep <- missing ]-      Right pkg' -> case constrainDeps pkg' newDeps constraints [] of-        Left failure       -> Failure failure-        Right (constraints', newDiscarded) ->-          searchSpace configure-            constraints' selected' (newSelected, newDiscarded) next'+      Right pkg' ->+        case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of+          Left failure       -> Failure failure+          Right (constraints', newDiscarded) ->+            searchSpace configure+              constraints' selected' (newSelected, newDiscarded) next'         where           selected' = foldl' (flip PackageIndex.insert) selected newSelected           newSelected =@@ -172,39 +182,45 @@                     (PackageIndex.lookupPackageId available pkgid')            newPkgs   = [ name'-                      | dep <- newDeps-                      , let (Dependency name' _) = untagDependency dep+                      | (Dependency name' _, _) <- newDeps                       , null (PackageIndex.lookupPackageName selected' name') ]           newDeps   = concatMap packageConstraints newSelected           next'     = Set.delete name                     $ foldl' (flip Set.insert) next newPkgs -packageConstraints :: SelectedPackage -> [TaggedDependency]+packageConstraints :: SelectedPackage -> [(Dependency, Bool)] packageConstraints = either installedConstraints availableConstraints-                   . preferAvailable+                   . preferSource   where-    preferAvailable (InstalledOnly           pkg) = Left pkg-    preferAvailable (AvailableOnly           pkg) = Right pkg-    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg+    preferSource (InstalledOnly        pkg) = Left pkg+    preferSource (SourceOnly           pkg) = Right pkg+    preferSource (InstalledAndSource _ pkg) = Right pkg     installedConstraints (InstalledPackageEx    _ _ deps) =-      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)+      [ (thisPackageVersion dep, True)       | dep <- deps ]-    availableConstraints (SemiConfiguredPackage _ _ deps) =-      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]+    availableConstraints (SemiConfiguredPackage _ _ _ deps) =+      [ (dep, False) | dep <- deps ] -constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints-              -> [PackageIdentifier]-              -> Either Failure (Constraints, [PackageIdentifier])+addDeps :: Constraints -> [PackageName] -> Constraints+addDeps =+  foldr $ \pkgname cs ->+            case Constraints.addTarget pkgname cs of+              Satisfiable cs' () -> cs'+              _                  -> impossible "addDeps unsatisfiable"++constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints+              -> [PackageId]+              -> Either Failure (Constraints, [PackageId]) constrainDeps pkg []         cs discard =   case addPackageSelectConstraint (packageId pkg) cs of     Satisfiable cs' discard' -> Right (cs', discard' ++ discard)-    _                        -> impossible-constrainDeps pkg (dep:deps) cs discard =-  case addPackageDependencyConstraint (packageId pkg) dep cs of+    _                        -> impossible "constrainDeps unsatisfiable(1)"+constrainDeps pkg ((dep, installedConstraint):deps) cs discard =+  case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of     Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)-    Unsatisfiable            -> impossible+    Unsatisfiable            -> impossible "constrainDeps unsatisfiable(2)"     ConflictsWith conflicts  ->-      Left (DependencyConflict pkg dep conflicts)+      Left (DependencyConflict pkg dep installedConstraint conflicts)  -- ------------------------------------------------------------ -- * The main algorithm@@ -226,7 +242,11 @@ -- the standard 'DependencyResolver' interface. -- topDownResolver :: DependencyResolver-topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'+topDownResolver platform comp installedPkgIndex sourcePkgIndex+                preferences constraints targets =+    mapMessages (topDownResolver' platform comp+                                  (convert installedPkgIndex) sourcePkgIndex+                                  preferences constraints targets)   where     mapMessages :: Progress Log Failure a -> Progress String String a     mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done@@ -235,45 +255,60 @@ -- topDownResolver' :: Platform -> CompilerId                  -> PackageIndex InstalledPackage-                 -> PackageIndex AvailablePackage+                 -> PackageIndex SourcePackage                  -> (PackageName -> PackagePreferences)                  -> [PackageConstraint]                  -> [PackageName]                  -> Progress Log Failure [PlanPackage]-topDownResolver' platform comp installed available+topDownResolver' platform comp installedPkgIndex sourcePkgIndex                  preferences constraints targets =       fmap (uncurry finalise)     . (\cs -> search configure preferences cs initialPkgNames)-  =<< addTopLevelConstraints constraints constraintSet+  =<< pruneBottomUp platform comp+  =<< addTopLevelConstraints constraints+  =<< addTopLevelTargets targets emptyConstraintSet    where     configure   = configurePackage platform comp-    constraintSet :: Constraints-    constraintSet = Constraints.empty-      (annotateInstalledPackages             topSortNumber installed')-      (annotateAvailablePackages constraints topSortNumber available')-    (installed', available') = selectNeededSubset installed available-                                                  initialPkgNames-    topSortNumber = topologicalSortNumbering installed' available'+    emptyConstraintSet :: Constraints+    emptyConstraintSet = Constraints.empty+      (annotateInstalledPackages          topSortNumber installedPkgIndex')+      (annotateSourcePackages constraints topSortNumber sourcePkgIndex')+    (installedPkgIndex', sourcePkgIndex') =+      selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames+    topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex'      initialPkgNames = Set.fromList targets      finalise selected' constraints' =         PackageIndex.allPackages-      . fst . improvePlan installed' constraints'+      . fst . improvePlan installedPkgIndex' constraints'       . PackageIndex.fromList       $ finaliseSelectedPackages preferences selected' constraints' ++addTopLevelTargets :: [PackageName]+                   -> Constraints+                   -> Progress a Failure Constraints+addTopLevelTargets []         cs = Done cs+addTopLevelTargets (pkg:pkgs) cs =+  case Constraints.addTarget pkg cs of+    Satisfiable cs' ()       -> addTopLevelTargets pkgs cs'+    Unsatisfiable            -> Fail (NoSuchPackage pkg)+    ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts"++ addTopLevelConstraints :: [PackageConstraint] -> Constraints-                       -> Progress a Failure Constraints+                       -> Progress Log Failure Constraints addTopLevelConstraints []                                      cs = Done cs-addTopLevelConstraints (PackageFlagsConstraint   _   _  :deps) cs =+addTopLevelConstraints (PackageConstraintFlags   _   _  :deps) cs =   addTopLevelConstraints deps cs -addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =+addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs =   case addTopLevelVersionConstraint pkg ver cs of-    Satisfiable cs' _       ->-      addTopLevelConstraints deps cs'+    Satisfiable cs' pkgids  ->+      Step (AppliedVersionConstraint pkg ver pkgids)+           (addTopLevelConstraints deps cs')      Unsatisfiable           ->       Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)@@ -281,29 +316,93 @@     ConflictsWith conflicts ->       Fail (TopLevelVersionConstraintConflict pkg ver conflicts) -addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =+addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs =   case addTopLevelInstalledConstraint pkg cs of-    Satisfiable cs' _       -> addTopLevelConstraints deps cs'+    Satisfiable cs' pkgids  ->+      Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids)+           (addTopLevelConstraints deps cs')      Unsatisfiable           ->-      Fail (TopLevelInstallConstraintUnsatisfiable pkg)+      Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint)      ConflictsWith conflicts ->-      Fail (TopLevelInstallConstraintConflict pkg conflicts)+      Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts) +addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =+  case addTopLevelSourceConstraint pkg cs of+    Satisfiable cs' pkgids  ->+      Step (AppliedInstalledConstraint pkg SourceConstraint pkgids)+            (addTopLevelConstraints deps cs')++    Unsatisfiable           ->+      Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint)++    ConflictsWith conflicts ->+      Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)++addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs =+    addTopLevelConstraints deps cs++-- | Add exclusion on available packages that cannot be configured.+--+pruneBottomUp :: Platform -> CompilerId+              -> Constraints -> Progress Log Failure Constraints+pruneBottomUp platform comp constraints =+    foldr prune Done (initialPackages constraints) constraints++  where+    prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs+      where+        unconfigurable =+          [ (pkg, missing) -- if necessary we could look up missing reasons+          | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs+          , Left missing <- [configure cs pkg'] ]++    addExcludeConstraint (pkg, missing) rest cs =+      let reason = ExcludedByConfigureFail missing in+      case addPackageExcludeConstraint (packageId pkg) reason cs of+        Satisfiable cs' [pkgid]| packageId pkg == pkgid+                         -> Step (ExcludeUnconfigurable pkgid) (rest cs')+        Satisfiable _ _  -> impossible "pruneBottomUp satisfiable"+        _                -> Fail $ ConfigureFailed pkg+                              [ (dep, Constraints.conflicting cs dep)+                              | dep <- missing ]++    configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags stanzas) =+      finalizePackageDescription flags (dependencySatisfiable cs)+                                 platform comp [] (enableStanzas stanzas pkg)+    dependencySatisfiable cs =+      not . null . PackageIndex.lookupDependency (Constraints.choices cs)++    -- collect each group of packages (by name) in reverse topsort order+    initialPackages =+        reverse+      . sortBy (comparing (topSortNumber . head))+      . PackageIndex.allPackagesByName+      . Constraints.choices++    topSortNumber (InstalledOnly        (InstalledPackageEx  _ i _)) = i+    topSortNumber (SourceOnly           (UnconfiguredPackage _ i _ _)) = i+    topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i++    getSourcePkg (InstalledOnly      _     ) = Nothing+    getSourcePkg (SourceOnly           spkg) = Just spkg+    getSourcePkg (InstalledAndSource _ spkg) = Just spkg++ configurePackage :: Platform -> CompilerId -> ConfigurePackage configurePackage platform comp available spkg = case spkg of-  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)-  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)-  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)-                                          (configure apkg)+  InstalledOnly      ipkg      -> Right (InstalledOnly ipkg)+  SourceOnly              apkg -> fmap SourceOnly (configure apkg)+  InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)+                                       (configure apkg)   where-  configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =+  configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags stanzas) =     case finalizePackageDescription flags dependencySatisfiable-                                    platform comp [] p of+                                    platform comp [] (enableStanzas stanzas p) of       Left missing        -> Left missing       Right (pkg, flags') -> Right $-        SemiConfiguredPackage apkg flags' (externalBuildDepends pkg)+        SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg)    dependencySatisfiable = not . null . PackageIndex.lookupDependency available @@ -317,7 +416,7 @@   [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)   | pkg <- PackageIndex.allPackages installed ]   where-    transitiveDepends :: InstalledPackage -> [PackageIdentifier]+    transitiveDepends :: InstalledPackage -> [PackageId]     transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph                       . fromJust . toVertex . packageId     (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed@@ -326,19 +425,24 @@ -- | Annotate each available packages with its topological sort number and any -- user-supplied partial flag assignment. ---annotateAvailablePackages :: [PackageConstraint]-                          -> (PackageName -> TopologicalSortNumber)-                          -> PackageIndex AvailablePackage-                          -> PackageIndex UnconfiguredPackage-annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList-  [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)-  | pkg <- PackageIndex.allPackages available-  , let name = packageName pkg ]+annotateSourcePackages :: [PackageConstraint]+                       -> (PackageName -> TopologicalSortNumber)+                       -> PackageIndex SourcePackage+                       -> PackageIndex UnconfiguredPackage+annotateSourcePackages constraints dfsNumber sourcePkgIndex =+    PackageIndex.fromList+      [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name)+      | pkg <- PackageIndex.allPackages sourcePkgIndex+      , let name = packageName pkg ]   where     flagsFor = fromMaybe [] . flip Map.lookup flagsMap     flagsMap = Map.fromList       [ (name, flags)-      | PackageFlagsConstraint name flags <- constraints ]+      | PackageConstraintFlags name flags <- constraints ]+    stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap+    stanzasMap = Map.fromListWith (++)+        [ (name, stanzas)+        | PackageConstraintStanzas name stanzas <- constraints ]  -- | One of the heuristics we use when guessing which path to take in the -- search space is an ordering on the choices we make. It's generally better@@ -352,7 +456,7 @@ -- one possible choice for B in which case we pick that immediately). -- -- To construct these topological sort numbers we combine and flatten the--- installed and available package sets. We consider only dependencies between+-- installed and source package sets. We consider only dependencies between -- named packages, not including versions and for not-yet-configured packages -- we look at all the possible dependencies, not just those under any single -- flag assignment. This means we can actually get impossible combinations of@@ -360,9 +464,9 @@ -- heuristic. -- topologicalSortNumbering :: PackageIndex InstalledPackage-                         -> PackageIndex AvailablePackage+                         -> PackageIndex SourcePackage                          -> (PackageName -> TopologicalSortNumber)-topologicalSortNumbering installed available =+topologicalSortNumbering installedPkgIndex sourcePkgIndex =     \pkgname -> let Just vertex = toVertex pkgname                  in topologicalSortNumbers Array.! vertex   where@@ -370,14 +474,14 @@                                          (zip (Graph.topSort graph) [0..])     (graph, _, toVertex)   = Graph.graphFromEdges $          [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex          , let deps = [ packageName dep                       | pkg' <- pkgs                       , dep  <- depends pkg' ] ]       ++ [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex          , let deps = [ depName-                      | AvailablePackage _ pkg' _ <- pkgs+                      | SourcePackage _ pkg' _ <- pkgs                       , Dependency depName _ <-                           buildDepends (flattenPackageDescription pkg') ] ] @@ -387,24 +491,24 @@ -- and looking at the names of all possible dependencies. -- selectNeededSubset :: PackageIndex InstalledPackage-                   -> PackageIndex AvailablePackage+                   -> PackageIndex SourcePackage                    -> Set PackageName                    -> (PackageIndex InstalledPackage-                      ,PackageIndex AvailablePackage)-selectNeededSubset installed available = select mempty mempty+                      ,PackageIndex SourcePackage)+selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty   where     select :: PackageIndex InstalledPackage-           -> PackageIndex AvailablePackage+           -> PackageIndex SourcePackage            -> Set PackageName            -> (PackageIndex InstalledPackage-              ,PackageIndex AvailablePackage)-    select installed' available' remaining-      | Set.null remaining = (installed', available')-      | otherwise = select installed'' available'' remaining''+              ,PackageIndex SourcePackage)+    select installedPkgIndex' sourcePkgIndex' remaining+      | Set.null remaining = (installedPkgIndex', sourcePkgIndex')+      | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining''       where         (next, remaining') = Set.deleteFindMin remaining-        moreInstalled = PackageIndex.lookupPackageName installed next-        moreAvailable = PackageIndex.lookupPackageName available next+        moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next+        moreSource    = PackageIndex.lookupPackageName sourcePkgIndex next         moreRemaining = -- we filter out packages already included in the indexes                         -- this avoids an infinite loop if a package depends on itself                         -- like base-3.0.3.0 with base-4.0.0.0@@ -413,14 +517,18 @@                         | pkg <- moreInstalled                         , dep <- depends pkg ]                      ++ [ name-                        | AvailablePackage _ pkg _ <- moreAvailable+                        | SourcePackage _ pkg _ <- moreSource                         , Dependency name _ <-                             buildDepends (flattenPackageDescription pkg) ]-        installed''   = foldl' (flip PackageIndex.insert) installed' moreInstalled-        available''   = foldl' (flip PackageIndex.insert) available' moreAvailable-        remaining''   = foldl' (flip         Set.insert) remaining' moreRemaining-        notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name)-                                  && null (PackageIndex.lookupPackageName available' name)+        installedPkgIndex'' = foldl' (flip PackageIndex.insert)+                                     installedPkgIndex' moreInstalled+        sourcePkgIndex''    = foldl' (flip PackageIndex.insert)+                                     sourcePkgIndex' moreSource+        remaining''         = foldl' (flip          Set.insert)+                                     remaining' moreRemaining+        notAlreadyIncluded name =+            null (PackageIndex.lookupPackageName installedPkgIndex' name)+         && null (PackageIndex.lookupPackageName sourcePkgIndex' name)  -- ------------------------------------------------------------ -- * Post processing the solution@@ -434,24 +542,26 @@   map finaliseSelected (PackageIndex.allPackages selected)   where     remainingChoices = Constraints.choices constraints-    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg-    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable Nothing apkg-    finaliseSelected (InstalledAndAvailable ipkg apkg) =+    finaliseSelected (InstalledOnly      ipkg     ) = finaliseInstalled ipkg+    finaliseSelected (SourceOnly              apkg) = finaliseSource Nothing apkg+    finaliseSelected (InstalledAndSource ipkg apkg) =       case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of-        Nothing                          -> impossible --picked package not in constraints-        Just (AvailableOnly _)           -> impossible --to constrain to avail only-        Just (InstalledOnly _)           -> finaliseInstalled ipkg-        Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg+                                        --picked package not in constraints+        Nothing                       -> impossible "finaliseSelected no pkg"+                                        -- to constrain to avail only:+        Just (SourceOnly _)           -> impossible "finaliseSelected src only"+        Just (InstalledOnly _)        -> finaliseInstalled ipkg+        Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg      finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg-    finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) =-      InstallPlan.Configured (ConfiguredPackage pkg flags deps')+    finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =+      InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')       where         deps' = map (packageId . pickRemaining mipkg) deps      pickRemaining mipkg dep@(Dependency _name versionRange) =           case PackageIndex.lookupDependency remainingChoices dep of-            []        -> impossible+            []        -> impossible "pickRemaining no pkg"             [pkg']    -> pkg'             remaining -> assert (checkIsPaired remaining)                        $ maximumBy bestByPref remaining@@ -540,14 +650,14 @@      constraintsOk _     []              constraints = Just constraints     constraintsOk pkgid (pkgid':pkgids) constraints =-      case addPackageDependencyConstraint pkgid dep constraints of+      case addPackageDependencyConstraint pkgid dep True constraints of         Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'         _                          -> Nothing       where-        dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')+        dep = thisPackageVersion pkgid'      reverseTopologicalOrder :: PackageFixedDeps pkg-                            => PackageIndex pkg -> [PackageIdentifier]+                            => PackageIndex pkg -> [PackageId]     reverseTopologicalOrder index = map (packageId . toPkg)                                   . Graph.topSort                                   . Graph.transposeG@@ -558,55 +668,68 @@ -- * Adding and recording constraints -- ------------------------------------------------------------ -addPackageSelectConstraint :: PackageIdentifier -> Constraints+addPackageSelectConstraint :: PackageId -> Constraints                            -> Satisfiable Constraints-                                [PackageIdentifier] ExclusionReason-addPackageSelectConstraint pkgid constraints =-  Constraints.constrain dep reason constraints+                                [PackageId] ExclusionReason+addPackageSelectConstraint pkgid =+    Constraints.constrain pkgname constraint reason   where-    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)-    reason = SelectedOther pkgid+    pkgname          = packageName pkgid+    constraint ver _ = ver == packageVersion pkgid+    reason           = SelectedOther pkgid -addPackageExcludeConstraint :: PackageIdentifier -> Constraints+addPackageExcludeConstraint :: PackageId -> ExclusionReason+                            -> Constraints                             -> Satisfiable Constraints-                                 [PackageIdentifier] ExclusionReason-addPackageExcludeConstraint pkgid constraints =-  Constraints.constrain dep reason constraints+                                           [PackageId] ExclusionReason+addPackageExcludeConstraint pkgid reason =+    Constraints.constrain pkgname constraint reason   where-    dep    = TaggedDependency NoInstalledConstraint-               (notThisPackageVersion pkgid)-    reason = ExcludedByConfigureFail+    pkgname = packageName pkgid+    constraint ver installed+      | ver == packageVersion pkgid = installed+      | otherwise                   = True -addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints+addPackageDependencyConstraint :: PackageId -> Dependency -> Bool+                               -> Constraints                                -> Satisfiable Constraints-                                    [PackageIdentifier] ExclusionReason-addPackageDependencyConstraint pkgid dep constraints =-  Constraints.constrain dep reason constraints+                                    [PackageId] ExclusionReason+addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange)+                                     installedConstraint =+    Constraints.constrain pkgname constraint reason   where-    reason = ExcludedByPackageDependency pkgid dep+    constraint ver installed = ver `withinRange` verrange+                            && if installedConstraint then installed else True+    reason = ExcludedByPackageDependency pkgid dep installedConstraint  addTopLevelVersionConstraint :: PackageName -> VersionRange                              -> Constraints                              -> Satisfiable Constraints-                                  [PackageIdentifier] ExclusionReason-addTopLevelVersionConstraint pkg ver constraints =-  Constraints.constrain taggedDep reason constraints+                                  [PackageId] ExclusionReason+addTopLevelVersionConstraint pkgname verrange =+    Constraints.constrain pkgname constraint reason   where-    dep       = Dependency pkg ver-    taggedDep = TaggedDependency NoInstalledConstraint dep-    reason    = ExcludedByTopLevelDependency dep+    constraint ver _installed = ver `withinRange` verrange+    reason = ExcludedByTopLevelConstraintVersion pkgname verrange -addTopLevelInstalledConstraint :: PackageName-                               -> Constraints-                               -> Satisfiable Constraints-                                    [PackageIdentifier] ExclusionReason-addTopLevelInstalledConstraint pkg constraints =-  Constraints.constrain taggedDep reason constraints+addTopLevelInstalledConstraint,+  addTopLevelSourceConstraint :: PackageName+                              -> Constraints+                              -> Satisfiable Constraints+                                   [PackageId] ExclusionReason+addTopLevelInstalledConstraint pkgname =+    Constraints.constrain pkgname constraint reason   where-    dep       = Dependency pkg anyVersion-    taggedDep = TaggedDependency InstalledConstraint dep-    reason    = ExcludedByTopLevelDependency dep+    constraint _ver installed = installed+    reason = ExcludedByTopLevelConstraintInstalled pkgname +addTopLevelSourceConstraint pkgname =+    Constraints.constrain pkgname constraint reason+  where+    constraint _ver installed = not installed+    reason = ExcludedByTopLevelConstraintSource pkgname++ -- ------------------------------------------------------------ -- * Reasons for constraints -- ------------------------------------------------------------@@ -619,60 +742,80 @@       -- | We selected this other version of the package. That means we exclude      -- all the other versions.-     SelectedOther PackageIdentifier+     SelectedOther PackageId       -- | We excluded this version of the package because it failed to      -- configure probably because of unsatisfiable deps.-   | ExcludedByConfigureFail+   | ExcludedByConfigureFail [Dependency]       -- | We excluded this version of the package because another package that      -- we selected imposed a dependency which this package did not satisfy.-   | ExcludedByPackageDependency PackageIdentifier TaggedDependency+   | ExcludedByPackageDependency PackageId Dependency Bool       -- | We excluded this version of the package because it did not satisfy      -- a dependency given as an original top level input.      ---   | ExcludedByTopLevelDependency Dependency+   | ExcludedByTopLevelConstraintVersion   PackageName VersionRange+   | ExcludedByTopLevelConstraintInstalled PackageName+   | ExcludedByTopLevelConstraintSource    PackageName +  deriving Eq+ -- | Given an excluded package and the reason it was excluded, produce a human -- readable explanation. ---showExclusionReason :: PackageIdentifier -> ExclusionReason -> String+showExclusionReason :: PackageId -> ExclusionReason -> String showExclusionReason pkgid (SelectedOther pkgid') =   display pkgid ++ " was excluded because " ++   display pkgid' ++ " was selected instead"-showExclusionReason pkgid ExcludedByConfigureFail =-  display pkgid ++ " was excluded because it could not be configured"-showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =-  display pkgid ++ " was excluded because " ++-  display pkgid' ++ " requires " ++ displayDep (untagDependency dep)-showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =-  display pkgid ++ " was excluded because of the top level dependency " ++-  displayDep dep+showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) =+  display pkgid ++ " was excluded because it could not be configured. "+  ++ "It requires " ++ listOf displayDep missingDeps+showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint)+  = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires "+ ++ (if installedConstraint then "an installed instance of " else "")+ ++ displayDep dep+showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) =+  display pkgid ++ " was excluded because of the top level constraint " +++  displayDep (Dependency pkgname verRange)+showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname)+  = display pkgid ++ " was excluded because of the top level constraint '"+ ++ display pkgname ++ " installed' which means that only installed instances "+ ++ "of the package may be selected."+showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname)+  = display pkgid ++ " was excluded because of the top level constraint '"+ ++ display pkgname ++ " source' which means that only source versions "+ ++ "of the package may be selected."   -- ------------------------------------------------------------ -- * Logging progress and failures -- ------------------------------------------------------------ -data Log = Select [SelectedPackage] [PackageIdentifier]+data Log = Select [SelectedPackage] [PackageId]+         | AppliedVersionConstraint   PackageName VersionRange [PackageId]+         | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId]+         | ExcludeUnconfigurable PackageId+ data Failure-   = ConfigureFailed+   = NoSuchPackage+       PackageName+   | ConfigureFailed        SelectablePackage-       [(Dependency, [(PackageIdentifier, [ExclusionReason])])]+       [(Dependency, [(PackageId, [ExclusionReason])])]    | DependencyConflict-       SelectedPackage TaggedDependency-       [(PackageIdentifier, [ExclusionReason])]+       SelectedPackage Dependency Bool+       [(PackageId, [ExclusionReason])]    | TopLevelVersionConstraintConflict        PackageName VersionRange-       [(PackageIdentifier, [ExclusionReason])]+       [(PackageId, [ExclusionReason])]    | TopLevelVersionConstraintUnsatisfiable        PackageName VersionRange    | TopLevelInstallConstraintConflict-       PackageName-       [(PackageIdentifier, [ExclusionReason])]+       PackageName InstalledConstraint+       [(PackageId, [ExclusionReason])]    | TopLevelInstallConstraintUnsatisfiable-       PackageName+       PackageName InstalledConstraint  showLog :: Log -> String showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of@@ -689,9 +832,9 @@               : [ display (packageVersion s') ++ " " ++ kind s'                 | s' <- ss ] -    kind (InstalledOnly _)           = "(installed)"-    kind (AvailableOnly _)           = "(hackage)"-    kind (InstalledAndAvailable _ _) = "(installed or hackage)"+    kind (InstalledOnly _)        = "(installed)"+    kind (SourceOnly _)           = "(source)"+    kind (InstalledAndSource _ _) = "(installed or source)"      discardedMsg = case discarded of       []  -> ""@@ -699,8 +842,23 @@         [ element         | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)         , element <- display pkgid : map (display . packageVersion) pkgids ]+showLog (AppliedVersionConstraint pkgname ver pkgids) =+     "applying constraint " ++ display (Dependency pkgname ver)+  ++ if null pkgids+       then ""+       else "which excludes " ++ listOf display pkgids+showLog (AppliedInstalledConstraint pkgname inst pkgids) =+     "applying constraint " ++ display pkgname ++ " '"+  ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "+  ++ if null pkgids+       then ""+       else "which excludes " ++ listOf display pkgids+showLog (ExcludeUnconfigurable pkgid) =+     "excluding " ++ display pkgid ++ " (it cannot be configured)"  showFailure :: Failure -> String+showFailure (NoSuchPackage pkgname) =+     "The package " ++ display pkgname ++ " is unknown." showFailure (ConfigureFailed pkg missingDeps) =      "cannot configure " ++ displayPkg pkg ++ ". It requires "   ++ listOf (displayDep . fst) missingDeps@@ -720,15 +878,17 @@        where pkgs = map fst conflicts -showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =+showFailure (DependencyConflict pkg dep installedConstraint conflicts) =      "dependencies conflict: "-  ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n"+  ++ displayPkg pkg ++ " requires "+  ++ (if installedConstraint then "an installed instance of " else "")+  ++ displayDep dep ++ " however:\n"   ++ unlines [ showExclusionReason (packageId pkg') reason              | (pkg', reasons) <- conflicts, reason <- reasons ]  showFailure (TopLevelVersionConstraintConflict name ver conflicts) =-     "constraints conflict: "-  ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n"+     "constraints conflict: we have the top level constraint "+  ++ displayDep (Dependency name ver) ++ ", but\n"   ++ unlines [ showExclusionReason (packageId pkg') reason              | (pkg', reasons) <- conflicts, reason <- reasons ] @@ -736,31 +896,37 @@      "There is no available version of " ++ display name       ++ " that satisfies " ++ displayVer ver -showFailure (TopLevelInstallConstraintConflict name conflicts) =+showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) =      "constraints conflict: "-  ++ "top level constraint " ++ display name ++ "-installed however\n"+  ++ "top level constraint '" ++ display name ++ " installed' however\n"   ++ unlines [ showExclusionReason (packageId pkg') reason              | (pkg', reasons) <- conflicts, reason <- reasons ] -showFailure (TopLevelInstallConstraintUnsatisfiable name) =+showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) =      "There is no installed version of " ++ display name +showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) =+     "constraints conflict: "+  ++ "top level constraint '" ++ display name ++ " source' however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) =+     "There is no available source version of " ++ display name+ displayVer :: VersionRange -> String displayVer = display . simplifyVersionRange  displayDep :: Dependency -> String displayDep = display . simplifyDependency -simplifyDependency :: Dependency -> Dependency-simplifyDependency (Dependency name range) =-  Dependency name (simplifyVersionRange range)  -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ -impossible :: a-impossible = internalError "impossible"+impossible :: String -> a+impossible msg = internalError $ "assertion failure: " ++ msg  internalError :: String -> a internalError msg = error $ "internal error: " ++ msg

Distribution/Client/Dependency/TopDown/Constraints.hs view

@@ -8,14 +8,16 @@ -- Stability   :  provisional -- Portability :  portable ----- A set of satisfiable dependencies (package version constraints).+-- A set of satisfiable constraints on a set of packages. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.TopDown.Constraints (   Constraints,   empty,+  packages,   choices,   isPaired, +  addTarget,   constrain,   Satisfiable(..),   conflicting,@@ -25,61 +27,103 @@ import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Package-         ( PackageName, PackageIdentifier(..)+         ( PackageName, PackageId, PackageIdentifier(..)          , Package(packageId), packageName, packageVersion-         , PackageFixedDeps(depends)-         , Dependency(Dependency) )+         , Dependency, PackageFixedDeps(depends) ) import Distribution.Version-         ( Version, withinRange )+         ( Version ) import Distribution.Client.Utils          ( mergeBy, MergeResult(..) ) -import Data.List-         ( foldl' ) import Data.Monoid          ( Monoid(mempty) )-import Data.Maybe-         ( catMaybes )+import Data.Either+         ( partitionEithers ) import qualified Data.Map as Map import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set) import Control.Exception          ( assert ) --- | A set of constraints on package versions. For each package name we record--- what other packages depends on it and what constraints they impose on the--- version of the package.++-- | A set of satisfiable constraints on a set of packages. ---data (Package installed, Package available)-  => Constraints installed available reason+-- The 'Constraints' type keeps track of a set of targets (identified by+-- package name) that we know that we need. It also keeps track of a set of+-- constraints over all packages in the environment.+--+-- It maintains the guarantee that, for the target set, the constraints are+-- satisfiable, meaning that there is at least one instance available for each+-- package name that satisfies the constraints on that package name.+--+-- Note that it is possible to over-constrain a package in the environment that+-- is not in the target set -- the satisfiability guarantee is only maintained+-- for the target set. This is useful because it allows us to exclude packages+-- without needing to know if it would ever be needed or not (e.g. allows+-- excluding broken installed packages).+--+-- Adding a constraint for a target package can fail if it would mean that+-- there are no remaining choices.+--+-- Adding a constraint for package that is not a target never fails.+--+-- Adding a new target package can fail if that package already has conflicting+-- constraints.+--+data Constraints installed source reason    = Constraints -       -- Remaining available choices-       (PackageIndex (InstalledOrAvailable installed available))+       -- | Targets that we know we need. This is the set for which we+       -- guarantee the constraints are satisfiable.+       !(Set PackageName) -       -- Paired choices-       (Map PackageName (Version, Version))+       -- | The available/remaining set. These are packages that have available+       -- choices remaining. This is guaranteed to cover the target packages,+       -- but can also cover other packages in the environment. New targets can+       -- only be added if there are available choices remaining for them.+       !(PackageIndex (InstalledOrSource installed source)) -       -- Choices that we have excluded for some reason-       -- usually by applying constraints-       (PackageIndex (ExcludedPackage PackageIdentifier reason))+       -- | The excluded set. Choices that we have excluded by applying+       -- constraints. Excluded choices are tagged with the reason.+       !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason)) -       -- Purely for the invariant, we keep a copy of the original index-       (PackageIndex (InstalledOrAvailable installed available))+       -- | Paired choices, this is an ugly hack.+       !(Map PackageName (Version, Version)) +       -- | Purely for the invariant, we keep a copy of the original index+       !(PackageIndex (InstalledOrSource installed source)) -data ExcludedPackage pkg reason-   = ExcludedPackage pkg [reason] -- reasons for excluding just the available-                         [reason] -- reasons for excluding installed and avail -instance Package pkg => Package (ExcludedPackage pkg reason) where-  packageId (ExcludedPackage p _ _) = packageId p+-- | Reasons for excluding all, or some choices for a package version.+--+-- Each package version can have a source instance, an installed instance or+-- both. We distinguish reasons for constraints that excluded both instances,+-- from reasons for constraints that excluded just one instance.+--+data ExcludedPkg pkg reason+   = ExcludedPkg pkg+       [reason] -- ^ reasons for excluding both source and installed instances+       [reason] -- ^ reasons for excluding the installed instance+       [reason] -- ^ reasons for excluding the source instance +instance Package pkg => Package (ExcludedPkg pkg reason) where+  packageId (ExcludedPkg p _ _ _) = packageId p++ -- | There is a conservation of packages property. Packages are never gained or--- lost, they just transfer from the remaining pot to the excluded pot.+-- lost, they just transfer from the remaining set to the excluded set. ---invariant :: (Package installed, Package available)-          => Constraints installed available a -> Bool-invariant (Constraints available _ excluded original) = all check merged+invariant :: (Package installed, Package source)+          => Constraints installed source a -> Bool+invariant (Constraints targets available excluded _ original) =++    -- Relationship between available, excluded and original+    all check merged++    -- targets is a subset of available+ && all (PackageIndex.elemByPackageName available) (Set.elems targets)+   where     merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)                      (PackageIndex.allPackages original)@@ -91,86 +135,113 @@         mergedPackageId (OnlyInRight   p) = packageId p         mergedPackageId (InBoth      p _) = packageId p +    -- If the package was originally installed only, then     check (InBoth (InstalledOnly _) cur) = case cur of-      -- If the package was originally installed only then       -- now it's either still remaining as installed only-      -- or it has been excluded in which case we excluded both-      -- installed and available since it was only installed-      OnlyInLeft  (InstalledOnly _)            -> True-      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True-      _                                        -> False+      OnlyInLeft               (InstalledOnly _)              -> True+      -- or it has been excluded+      OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True+      _                                                       -> False -    check (InBoth (AvailableOnly _) cur) = case cur of-      -- If the package was originally available only then-      -- now it's either still remaining as available only-      -- or it has been excluded in which case we excluded both-      -- installed and available since it was only available-      OnlyInLeft  (AvailableOnly   _)          -> True-      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True-      _                                        -> True+    -- If the package was originally available only, then+    check (InBoth (SourceOnly _) cur) = case cur of+      -- now it's either still remaining as source only+      OnlyInLeft               (SourceOnly _)              -> True+      -- or it has been excluded+      OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True+      _                                                    -> False -    -- If the package was originally installed and available-    -- then there are three cases.-    check (InBoth (InstalledAndAvailable _ _) cur) = case cur of+    -- If the package was originally installed and source, then+    check (InBoth (InstalledAndSource _ _) cur) = case cur of       -- We can have both remaining:-      OnlyInLeft                    (InstalledAndAvailable _ _)  -> True-      -- both excluded, in particular it can have had the available excluded-      -- and later had both excluded so we do not mind if the available excluded-      -- is empty or non-empty.-      OnlyInRight                   (ExcludedPackage _ _  (_:_)) -> True-      -- the installed remaining and the available excluded:-      InBoth      (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True-      _                                                          -> False+      OnlyInLeft               (InstalledAndSource _ _)        -> True +      -- both excluded, in particular it can have had the just source or+      -- installed excluded and later had both excluded so we do not mind if+      -- the source or installed excluded is empty or non-empty.+      OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True++      -- the installed remaining and the source excluded:+      InBoth                   (InstalledOnly _)+                  (ExcludedPkg (SourceOnly _) [] [] (_:_))     -> True++      -- the source remaining and the installed excluded:+      InBoth                   (SourceOnly _)+                  (ExcludedPkg (InstalledOnly _) [] (_:_) [])  -> True+      _                                                        -> False+     check _ = False + -- | An update to the constraints can move packages between the two piles -- but not gain or loose packages.-transitionsTo :: (Package installed, Package available)-              => Constraints installed available a-              -> Constraints installed available a -> Bool-transitionsTo constraints @(Constraints available  _ excluded  _)-              constraints'@(Constraints available' _ excluded' _) =+transitionsTo :: (Package installed, Package source)+              => Constraints installed source a+              -> Constraints installed source a -> Bool+transitionsTo constraints @(Constraints _ available  excluded  _ _)+              constraints'@(Constraints _ available' excluded' _ _) =+      invariant constraints && invariant constraints'   && null availableGained  && null excludedLost-  && map packageId availableLost == map packageId excludedGained+  &&    map (mapInstalledOrSource packageId packageId) availableLost+     == map (mapInstalledOrSource packageId packageId) excludedGained    where-    availableLost   = foldr lost [] availableChange where-      lost (OnlyInLeft  pkg)          rest = pkg : rest-      lost (InBoth (InstalledAndAvailable _ pkg)-                   (InstalledOnly _)) rest = AvailableOnly pkg : rest-      lost _                          rest = rest-    availableGained = [ pkg | OnlyInRight pkg <- availableChange ]-    excludedLost    = [ pkg | OnlyInLeft  pkg <- excludedChange  ]-    excludedGained  = [ pkg | OnlyInRight pkg <- excludedChange  ]-                   ++ [ pkg | InBoth (ExcludedPackage _ (_:_) [])-                                 pkg@(ExcludedPackage _ (_:_) (_:_))-                                              <- excludedChange  ]-    availableChange = mergeBy (\a b -> packageId a `compare` packageId b)-                              (PackageIndex.allPackages available)-                              (PackageIndex.allPackages available')-    excludedChange  = mergeBy (\a b -> packageId a `compare` packageId b)-                              (PackageIndex.allPackages excluded)-                              (PackageIndex.allPackages excluded')+    (availableLost, availableGained)+      = partitionEithers (foldr lostAndGained [] availableChange) +    (excludedLost, excludedGained)+      = partitionEithers (foldr lostAndGained [] excludedChange)++    availableChange =+      mergeBy (\a b -> packageId a `compare` packageId b)+        (PackageIndex.allPackages available)+        (PackageIndex.allPackages available')++    excludedChange =+      mergeBy (\a b -> packageId a `compare` packageId b)+        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded  ]+        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ]++    lostAndGained mr rest = case mr of+      OnlyInLeft pkg                    -> Left pkg : rest+      InBoth (InstalledAndSource pkg _)+             (SourceOnly _)             -> Left (InstalledOnly pkg) : rest+      InBoth (InstalledAndSource _ pkg)+             (InstalledOnly _)          -> Left (SourceOnly pkg) : rest+      InBoth (SourceOnly _)+             (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest+      InBoth (InstalledOnly _)+             (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest+      OnlyInRight pkg                   -> Right pkg : rest+      _                                 -> rest++    mapInstalledOrSource f g pkg = case pkg of+      InstalledOnly      a   -> InstalledOnly (f a)+      SourceOnly           b -> SourceOnly    (g b)+      InstalledAndSource a b -> InstalledAndSource (f a) (g b)++ -- | We construct 'Constraints' with an initial 'PackageIndex' of all the -- packages available. ---empty :: (PackageFixedDeps installed, Package available)+empty :: (PackageFixedDeps installed, Package source)       => PackageIndex installed-      -> PackageIndex available-      -> Constraints installed available reason-empty installed available = Constraints pkgs pairs mempty pkgs+      -> PackageIndex source+      -> Constraints installed source reason+empty installed source =+    Constraints targets pkgs excluded pairs pkgs   where+    targets  = mempty+    excluded = mempty     pkgs = PackageIndex.fromList-         . map toInstalledOrAvailable+         . map toInstalledOrSource          $ mergeBy (\a b -> packageId a `compare` packageId b)                    (PackageIndex.allPackages installed)-                   (PackageIndex.allPackages available)-    toInstalledOrAvailable (OnlyInLeft  i  ) = InstalledOnly         i-    toInstalledOrAvailable (OnlyInRight   a) = AvailableOnly           a-    toInstalledOrAvailable (InBoth      i a) = InstalledAndAvailable i a+                   (PackageIndex.allPackages source)+    toInstalledOrSource (OnlyInLeft  i  ) = InstalledOnly      i+    toInstalledOrSource (OnlyInRight   a) = SourceOnly           a+    toInstalledOrSource (InBoth      i a) = InstalledAndSource i a      -- pick up cases like base-3 and 4 where one version depends on the other:     pairs = Map.fromList@@ -182,135 +253,348 @@       ,    any ((pkgid1==) . packageId) (depends pkg2)         || any ((pkgid2==) . packageId) (depends pkg1) ] ++-- | The package targets.+--+packages :: (Package installed, Package source)+         => Constraints installed source reason+         -> Set PackageName+packages (Constraints ts _ _ _ _) = ts++ -- | The package choices that are still available. ---choices :: (Package installed, Package available)-        => Constraints installed available reason-        -> PackageIndex (InstalledOrAvailable installed available)-choices (Constraints available _ _ _) = available+choices :: (Package installed, Package source)+        => Constraints installed source reason+        -> PackageIndex (InstalledOrSource installed source)+choices (Constraints _ available _ _ _) = available -isPaired :: (Package installed, Package available)-         => Constraints installed available reason-         -> PackageIdentifier -> Maybe PackageIdentifier-isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) =+isPaired :: (Package installed, Package source)+         => Constraints installed source reason+         -> PackageId -> Maybe PackageId+isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) =   case Map.lookup name pairs of     Just (v1, v2)       | version == v1 -> Just (PackageIdentifier name v2)       | version == v2 -> Just (PackageIdentifier name v1)     _                 -> Nothing + data Satisfiable constraints discarded reason        = Satisfiable constraints discarded        | Unsatisfiable-       | ConflictsWith [(PackageIdentifier, [reason])]+       | ConflictsWith [(PackageId, [reason])] -constrain :: (Package installed, Package available)-          => TaggedDependency-          -> reason-          -> Constraints installed available reason-          -> Satisfiable (Constraints installed available reason)-                         [PackageIdentifier] reason-constrain (TaggedDependency installedConstraint (Dependency name versionRange))-          reason constraints@(Constraints available paired excluded original) -  | not anyRemaining+addTarget :: (Package installed, Package source)+          => PackageName+          -> Constraints installed source reason+          -> Satisfiable (Constraints installed source reason)+                         () reason+addTarget pkgname+          constraints@(Constraints targets available excluded paired original)++    -- If it's already a target then there's no change+  | pkgname `Set.member` targets+  = Satisfiable constraints ()++    -- If there is some possible choice available for this target then we're ok+  | PackageIndex.elemByPackageName available pkgname+  = let targets'     = Set.insert pkgname targets+        constraints' = Constraints targets' available excluded paired original+     in assert (constraints `transitionsTo` constraints') $+        Satisfiable constraints' ()++    -- If it's not available and it is excluded then we return the conflicts+  | PackageIndex.elemByPackageName excluded pkgname+  = ConflictsWith conflicts++    -- Otherwise, it's not available and it has not been excluded so the+    -- package is simply completely unknown.+  | otherwise+  = Unsatisfiable++  where+    conflicts =+      [ (packageId pkg, reasons)+      | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname+      , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices+      , let reasons = isReasons ++ iReasons ++ sReasons ]+++constrain :: (Package installed, Package source)+          => PackageName                -- ^ which package to constrain+          -> (Version -> Bool -> Bool)  -- ^ the constraint test+          -> reason                     -- ^ the reason for the constraint+          -> Constraints installed source reason+          -> Satisfiable (Constraints installed source reason)+                         [PackageId] reason+constrain pkgname constraint reason+          constraints@(Constraints targets available excluded paired original)++  | pkgname `Set.member` targets  &&  not anyRemaining   = if null conflicts then Unsatisfiable                       else ConflictsWith conflicts    | otherwise-  = let constraints' = Constraints available' paired excluded' original+  = let constraints' = Constraints targets available' excluded' paired original      in assert (constraints `transitionsTo` constraints') $         Satisfiable constraints' (map packageId newExcluded)    where-  -- This tells us if any packages would remain at all for this package name if-  -- we applied this constraint. This amounts to checking if any package-  -- satisfies the given constraint, including version range and installation-  -- status.-  ---  anyRemaining = any satisfiesConstraint availableChoices+    -- This tells us if any packages would remain at all for this package name if+    -- we applied this constraint. This amounts to checking if any package+    -- satisfies the given constraint, including version range and installation+    -- status.+    --+    (available', excluded', newExcluded, anyRemaining, conflicts) =+      updatePkgsStatus+        available excluded+        [] False []+        (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg')+                 (PackageIndex.lookupPackageName available pkgname)+                 (PackageIndex.lookupPackageName excluded  pkgname)) -  conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)-              | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices-              , satisfiesVersionConstraint pkg ]+    testConstraint pkg =+      let ver = packageVersion pkg in+      case Map.lookup (packageName pkg) paired of -  -- Applying this constraint may involve deleting some choices for this-  -- package name, or restricting which install states are available.-  available' = updateAvailable available-  updateAvailable = flip (foldl' (flip update)) availableChoices where-    update pkg | not (satisfiesVersionConstraint pkg)-               = PackageIndex.deletePackageId (packageId pkg)-    update _   | installedConstraint == NoInstalledConstraint-               = id-    update pkg = case pkg of-      InstalledOnly         _   -> id-      AvailableOnly           _ -> PackageIndex.deletePackageId (packageId pkg)-      InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)+        Just (v1, v2)+          | ver == v1 || ver == v2+          -> case pkg of+               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)+               SourceOnly    spkg -> SourceOnly    (spkg, sOk)+               InstalledAndSource ipkg spkg ->+                 InstalledAndSource (ipkg, iOk) (spkg, sOk)+          where+            iOk = constraint v1 True  || constraint v2 True+            sOk = constraint v1 False || constraint v2 False -  -- Applying the constraint means adding exclusions for the packages that-  -- we're just freshly excluding, ie the ones we're removing from available.-  excluded' = foldl' (flip PackageIndex.insert) excluded-                (newExcluded ++ oldExcluded)+        _ -> case pkg of+               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)+               SourceOnly    spkg -> SourceOnly    (spkg, sOk)+               InstalledAndSource ipkg spkg ->+                 InstalledAndSource (ipkg, iOk) (spkg, sOk)+          where+            iOk = constraint ver True+            sOk = constraint ver False -  newExcluded = catMaybes (map exclude availableChoices) where-    exclude pkg-      | not (satisfiesVersionConstraint pkg)-      = Just (ExcludedPackage pkgid [] [reason])-      | installedConstraint == NoInstalledConstraint-      = Nothing-      | otherwise = case pkg of-      InstalledOnly         _   -> Nothing-      AvailableOnly           _ -> Just (ExcludedPackage pkgid [] [reason])-      InstalledAndAvailable _ _ ->-        case PackageIndex.lookupPackageId excluded pkgid of-          Just (ExcludedPackage _ avail both)-                  -> Just (ExcludedPackage pkgid (reason:avail) both)-          Nothing -> Just (ExcludedPackage pkgid [reason] [])-      where pkgid = packageId pkg+    -- For the info about available and excluded versions of the package in+    -- question, update the info given the current constraint+    --+    -- We update the available package map and the excluded package map+    -- we also collect:+    --   * the change in available packages (for logging)+    --   * whether there are any remaining choices+    --   * any constraints that conflict with the current constraint -  -- Additionally we have to add extra exclusions for any already-excluded-  -- packages that happen to be covered by the (inverse of the) constraint.-  oldExcluded = catMaybes (map exclude excludedChoices) where-    exclude (ExcludedPackage pkgid avail both)-      -- if it doesn't satisfy the version constraint then we exclude the-      -- package as a whole, the available or the installed instances or both.-      | not (satisfiesVersionConstraint pkgid)-      = Just (ExcludedPackage pkgid avail (reason:both))-      -- if on the other hand it does satisfy the constraint and we were also-      -- constraining to just the installed version then we exclude just the-      -- available instance.-      | installedConstraint == InstalledConstraint-      = Just (ExcludedPackage pkgid (reason:avail) both)-      | otherwise = Nothing+    updatePkgsStatus _ _ nePkgs ok cs _+      | seq nePkgs $ seq ok $ seq cs False = undefined -  -- util definitions-  availableChoices = PackageIndex.lookupPackageName available name-  excludedChoices  = PackageIndex.lookupPackageName excluded  name+    updatePkgsStatus aPkgs ePkgs nePkgs ok cs []+      = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs) -  satisfiesConstraint pkg = satisfiesVersionConstraint pkg-                         && satisfiesInstallStateConstraint pkg+    updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) =+        let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg+            nePkgs' = maybeCons mnePkg nePkgs+            cs'     = maybeCons mc cs+         in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs -  satisfiesVersionConstraint :: Package pkg => pkg -> Bool-  satisfiesVersionConstraint = case Map.lookup name paired of-    Nothing       -> \pkg ->-      packageVersion pkg `withinRange` versionRange-    Just (v1, v2) -> \pkg -> case packageVersion pkg of-      v | v == v1-       || v == v2   -> v1 `withinRange` versionRange-                    || v2 `withinRange` versionRange-        | otherwise -> v `withinRange` versionRange+    maybeCons Nothing  xs = xs+    maybeCons (Just x) xs = x:xs -  satisfiesInstallStateConstraint = case installedConstraint of-    NoInstalledConstraint -> \_   -> True-    InstalledConstraint   -> \pkg -> case pkg of-      AvailableOnly _             -> False-      _                           -> True -conflicting :: (Package installed, Package available)-            => Constraints installed available reason+    -- For the info about an available or excluded version of the package in+    -- question, update the info given the current constraint.+    --+    updatePkgStatus aPkgs ePkgs pkg =+      case viewPackageStatus pkg of+        AllAvailable (InstalledOnly (aiPkg, False)) ->+          removeAvailable False+            (InstalledOnly aiPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])+            Nothing++        AllAvailable (SourceOnly (asPkg, False)) ->+          removeAvailable False+            (SourceOnly asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])+            Nothing++        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) ->+          removeAvailable False+            (InstalledAndSource aiPkg asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] [])+            Nothing++        AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) ->+          removeAvailable True+            (SourceOnly asPkg)+            (PackageIndex.insert (InstalledOnly aiPkg))+            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])+            Nothing++        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) ->+          removeAvailable True+            (InstalledOnly aiPkg)+            (PackageIndex.insert (SourceOnly asPkg))+            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])+            Nothing++        AllAvailable _ -> noChange True Nothing++        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) ->+          removeAvailable False+            (InstalledOnly aiPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs)+            Nothing++        AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) ->+          addExtraExclusion True+            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))+            Nothing++        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) ->+          removeAvailable  True+            (InstalledOnly aiPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs)+            (Just (pkgid, srs))++        AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) ->+          noChange True+            (Just (pkgid, srs))++        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) ->+          removeAvailable  False+            (SourceOnly asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs [])+            Nothing++        ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) ->+          removeAvailable False+            (SourceOnly asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason])+            (Just (pkgid, irs))++        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) ->+          addExtraExclusion True+            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])+            Nothing++        ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) ->+          noChange True+            (Just (pkgid, irs))++        AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])+            Nothing++        AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) ->+          noChange False+            (Just (pkgid, irs))++        AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) ->+          addExtraExclusion False+            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))+            Nothing++        AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) ->+          noChange False+            (Just (pkgid, srs))++        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs)+            Nothing++        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs))+            (Just (pkgid, irs))++        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs)+            (Just (pkgid, srs))++        AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) ->+          noChange False+            (Just (pkgid, isrs ++ irs ++ srs))++      where+        removeAvailable ok nePkg adjustAvailable ePkg c =+          let aPkgs' = adjustAvailable aPkgs+              ePkgs' = PackageIndex.insert ePkg ePkgs+           in aPkgs' `seq` ePkgs' `seq`+              (aPkgs', ePkgs', Just nePkg, ok, c)++        addExtraExclusion ok ePkg c =+          let ePkgs' = PackageIndex.insert ePkg ePkgs+           in ePkgs' `seq`+              (aPkgs, ePkgs', Nothing, ok, c)++        noChange ok c =+          (aPkgs, ePkgs, Nothing, ok, c)++        pkgid = case pkg of OnlyInLeft  p   -> packageId p+                            OnlyInRight p   -> packageId p+                            InBoth      p _ -> packageId p+++    viewPackageStatus+      :: (Package installed, Package source)+      => MergeResult (InstalledOrSource installed source)+                     (ExcludedPkg (InstalledOrSource installed source) reason)+      -> PackageStatus (installed, Bool) (source, Bool) reason+    viewPackageStatus merged =+        case merged of+          OnlyInLeft aPkg ->+            AllAvailable (testConstraint aPkg)++          OnlyInRight (ExcludedPkg ePkg isrs irs srs) ->+            AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs)++          InBoth (InstalledOnly aiPkg)+                 (ExcludedPkg (SourceOnly esPkg) [] [] srs) ->+            case testConstraint (InstalledAndSource aiPkg esPkg) of+              InstalledAndSource (aiPkg', iOk) (esPkg', sOk) ->+                AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs)+              _ -> impossible++          InBoth (SourceOnly asPkg)+                 (ExcludedPkg (InstalledOnly eiPkg) [] irs []) ->+            case testConstraint (InstalledAndSource eiPkg asPkg) of+              InstalledAndSource (eiPkg', iOk) (asPkg', sOk) ->+                ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk)+              _ -> impossible+          _ -> impossible+      where+        impossible = error "impossible: viewPackageStatus invariant violation"++-- A intermediate structure that enumerates all the possible cases given the+-- invariant. This helps us to get simpler and complete pattern matching in+-- updatePkg above+--+data PackageStatus installed source reason+   = AllAvailable (InstalledOrSource installed source)+   | AllExcluded  (ExcludedPkg (InstalledOrSource installed source) reason)+   | AvailableExcluded installed (ExcludedPkg source reason)+   | ExcludedAvailable (ExcludedPkg installed reason) source+++conflicting :: (Package installed, Package source)+            => Constraints installed source reason             -> Dependency-            -> [(PackageIdentifier, [reason])]-conflicting (Constraints _ _ excluded _) dep =-  [ (pkgid, reasonsAvail ++ reasonsAll) --TODO-  | ExcludedPackage pkgid reasonsAvail reasonsAll <-+            -> [(PackageId, [reason])]+conflicting (Constraints _ _ excluded _ _) dep =+  [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO+  | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <-       PackageIndex.lookupDependency excluded dep ]

Distribution/Client/Dependency/TopDown/Types.hs view

@@ -13,7 +13,7 @@ module Distribution.Client.Dependency.TopDown.Types where  import Distribution.Client.Types-         ( AvailablePackage(..), InstalledPackage )+         ( SourcePackage(..), InstalledPackage, OptionalStanza )  import Distribution.Package          ( PackageIdentifier, Dependency@@ -26,15 +26,16 @@ -- ------------------------------------------------------------  type SelectablePackage-   = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage+   = InstalledOrSource InstalledPackageEx UnconfiguredPackage  type SelectedPackage-   = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage+   = InstalledOrSource InstalledPackageEx SemiConfiguredPackage -data InstalledOrAvailable installed available-   = InstalledOnly         installed-   | AvailableOnly                   available-   | InstalledAndAvailable installed available+data InstalledOrSource installed source+   = InstalledOnly      installed+   | SourceOnly                   source+   | InstalledAndSource installed source+  deriving Eq  type TopologicalSortNumber = Int @@ -46,14 +47,16 @@  data UnconfiguredPackage    = UnconfiguredPackage-       AvailablePackage+       SourcePackage        !TopologicalSortNumber        FlagAssignment+       [OptionalStanza]  data SemiConfiguredPackage    = SemiConfiguredPackage-       AvailablePackage  -- package info+       SourcePackage     -- package info        FlagAssignment    -- total flag assignment for the package+       [OptionalStanza]  -- enabled optional stanzas        [Dependency]      -- dependencies we end up with when we apply                          -- the flag assignment @@ -64,30 +67,25 @@   depends (InstalledPackageEx _ _ deps) = deps  instance Package UnconfiguredPackage where-  packageId (UnconfiguredPackage p _ _) = packageId p+  packageId (UnconfiguredPackage p _ _ _) = packageId p  instance Package SemiConfiguredPackage where-  packageId (SemiConfiguredPackage p _ _) = packageId p+  packageId (SemiConfiguredPackage p _ _ _) = packageId p -instance (Package installed, Package available)-      => Package (InstalledOrAvailable installed available) where-  packageId (InstalledOnly         p  ) = packageId p-  packageId (AvailableOnly         p  ) = packageId p-  packageId (InstalledAndAvailable p _) = packageId p+instance (Package installed, Package source)+      => Package (InstalledOrSource installed source) where+  packageId (InstalledOnly      p  ) = packageId p+  packageId (SourceOnly         p  ) = packageId p+  packageId (InstalledAndSource p _) = packageId p --- --------------------------------------------------------------- * Tagged Dependency type--- ------------------------------------------------------------ --- | Installed packages can only depend on other installed packages while--- packages that are not yet installed but which we plan to install can depend--- on installed or other not-yet-installed packages.+-- | We can have constraints on selecting just installed or just source+-- packages. ----- This makes life more complex as we have to remember these constraints.+-- In particular, installed packages can only depend on other installed+-- packages while packages that are not yet installed but which we plan to+-- install can depend on installed or other not-yet-installed packages. ---data TaggedDependency = TaggedDependency InstalledConstraint Dependency-data InstalledConstraint = InstalledConstraint | NoInstalledConstraint-  deriving Eq--untagDependency :: TaggedDependency -> Dependency-untagDependency (TaggedDependency _ dep) = dep+data InstalledConstraint = InstalledConstraint+                         | SourceConstraint+  deriving (Eq, Show)

Distribution/Client/Dependency/Types.hs view

@@ -11,35 +11,91 @@ -- Common types for dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.Types (+    ExtDependency(..),++    PreSolver(..),+    Solver(..),     DependencyResolver,      PackageConstraint(..),     PackagePreferences(..),     InstalledPreference(..),+    PackagesPreferenceDefault(..),      Progress(..),     foldProgress,   ) where +import Control.Applicative+         ( Applicative(..), Alternative(..) )++import Data.Char+         ( isAlpha, toLower )+import Data.Monoid+         ( Monoid(..) )+ import Distribution.Client.Types-         ( AvailablePackage(..), InstalledPackage )+         ( OptionalStanza, SourcePackage(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Compat.ReadP+         ( (<++) )++import qualified Distribution.Compat.ReadP as Parse+         ( pfail, munch1 ) import Distribution.PackageDescription          ( FlagAssignment )-import Distribution.Client.PackageIndex+import qualified Distribution.Client.PackageIndex as PackageIndex          ( PackageIndex )+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+         ( PackageIndex ) import Distribution.Package-         ( PackageName )+         ( Dependency, PackageName, InstalledPackageId ) import Distribution.Version          ( VersionRange ) import Distribution.Compiler          ( CompilerId ) import Distribution.System          ( Platform )+import Distribution.Text+         ( Text(..) ) +import Text.PrettyPrint+         ( text )+ import Prelude hiding (fail) +-- | Covers source dependencies and installed dependencies in+-- one type.+data ExtDependency = SourceDependency Dependency+                   | InstalledDependency InstalledPackageId++instance Text ExtDependency where+  disp (SourceDependency    dep) = disp dep+  disp (InstalledDependency dep) = disp dep++  parse = (SourceDependency `fmap` parse) <++ (InstalledDependency `fmap` parse)++-- | All the solvers that can be selected.+data PreSolver = AlwaysTopDown | AlwaysModular | Choose+  deriving (Eq, Ord, Show, Bounded, Enum)++-- | All the solvers that can be used.+data Solver = TopDown | Modular+  deriving (Eq, Ord, Show, Bounded, Enum)++instance Text PreSolver where+  disp AlwaysTopDown = text "topdown"+  disp AlwaysModular = text "modular"+  disp Choose        = text "choose"+  parse = do+    name <- Parse.munch1 isAlpha+    case map toLower name of+      "topdown" -> return AlwaysTopDown+      "modular" -> return AlwaysModular+      "choose"  -> return Choose+      _         -> Parse.pfail+ -- | A dependency resolver is a function that works out an installation plan -- given the set of installed and available packages and a set of deps to -- solve for.@@ -50,8 +106,8 @@ -- type DependencyResolver = Platform                        -> CompilerId-                       -> PackageIndex InstalledPackage-                       -> PackageIndex AvailablePackage+                       -> InstalledPackageIndex.PackageIndex+                       ->          PackageIndex.PackageIndex SourcePackage                        -> (PackageName -> PackagePreferences)                        -> [PackageConstraint]                        -> [PackageName]@@ -63,9 +119,11 @@ -- range or inconsistent flag assignment). -- data PackageConstraint-   = PackageVersionConstraint   PackageName VersionRange-   | PackageInstalledConstraint PackageName-   | PackageFlagsConstraint     PackageName FlagAssignment+   = PackageConstraintVersion   PackageName VersionRange+   | PackageConstraintInstalled PackageName+   | PackageConstraintSource    PackageName+   | PackageConstraintFlags     PackageName FlagAssignment+   | PackageConstraintStanzas   PackageName [OptionalStanza]   deriving (Show,Eq)  -- | A per-package preference on the version. It is a soft constraint that the@@ -85,6 +143,30 @@ -- data InstalledPreference = PreferInstalled | PreferLatest +-- | Global policy for all packages to say if we prefer package versions that+-- are already installed locally or if we just prefer the latest available.+--+data PackagesPreferenceDefault =++     -- | Always prefer the latest version irrespective of any existing+     -- installed version.+     --+     -- * This is the standard policy for upgrade.+     --+     PreferAllLatest++     -- | Always prefer the installed versions over ones that would need to be+     -- installed. Secondarily, prefer latest versions (eg the latest installed+     -- version or if there are none then the latest source version).+   | PreferAllInstalled++     -- | Prefer the latest version for packages that are explicitly requested+     -- but prefers the installed version for any other packages.+     --+     -- * This is the standard policy for install.+     --+   | PreferLatestForSelected+ -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final -- retult which may be used to indicate progress and\/or logging messages.@@ -113,3 +195,11 @@ instance Monad (Progress step fail) where   return a = Done a   p >>= f  = foldProgress Step Fail f p++instance Applicative (Progress step fail) where+  pure a  = Done a+  p <*> x = foldProgress Step Fail (flip fmap x) p++instance Monoid fail => Alternative (Progress step fail) where+  empty   = Fail mempty+  p <|> q = foldProgress Step (const q) Done p

Distribution/Client/Fetch.hs view

@@ -19,9 +19,8 @@ import Distribution.Client.Targets import Distribution.Client.FetchUtils hiding (fetchPackage) import Distribution.Client.Dependency-import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, getInstalledPackages )+         ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.Setup          ( GlobalFlags(..), FetchFlags(..) )@@ -30,6 +29,7 @@          ( packageId ) import Distribution.Simple.Compiler          ( Compiler(compilerId), PackageDBStack )+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Program          ( ProgramConfiguration ) import Distribution.Simple.Setup@@ -79,15 +79,17 @@      mapM_ checkTarget userTargets -    installed     <- getInstalledPackages verbosity comp packageDBs conf-    availableDb   <- getAvailablePackages verbosity repos+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos      pkgSpecifiers <- resolveUserTargets verbosity-                       globalFlags (packageIndex availableDb) userTargets+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       userTargets      pkgs  <- planPackages                verbosity comp fetchFlags-               installed availableDb pkgSpecifiers+               installedPkgIndex sourcePkgDb pkgSpecifiers      pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs     if null pkgs'@@ -110,25 +112,27 @@ planPackages :: Verbosity              -> Compiler              -> FetchFlags-             -> PackageIndex InstalledPackage-             -> AvailablePackageDb-             -> [PackageSpecifier AvailablePackage]-             -> IO [AvailablePackage]+             -> PackageIndex+             -> SourcePackageDb+             -> [PackageSpecifier SourcePackage]+             -> IO [SourcePackage] planPackages verbosity comp fetchFlags-             installed availableDb pkgSpecifiers+             installedPkgIndex sourcePkgDb pkgSpecifiers    | includeDependencies = do+      solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp)       notice verbosity "Resolving dependencies..."       installPlan <- foldProgress logMsg die return $                        resolveDependencies                          buildPlatform (compilerId comp)+                         solver                          resolverParams        -- The packages we want to fetch are those packages the 'InstallPlan'       -- that are in the 'InstallPlan.Configured' state.       return         [ pkg-        | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))+        | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _ _))             <- InstallPlan.toList installPlan ]    | otherwise =@@ -138,16 +142,30 @@   where     resolverParams = +        setMaxBackjumps (if maxBackjumps < 0 then Nothing+                                             else Just maxBackjumps)++      . setIndependentGoals independentGoals++      . setReorderGoals reorderGoals++      . setShadowPkgs shadowPkgs+         -- 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. Sicne we want to get the source packages of+        -- already installed. Since we want to get the source packages of         -- things we might have installed (but not have the sources for).-        reinstallTargets+      . reinstallTargets -      $ standardInstallPolicy installed availableDb pkgSpecifiers+      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers      includeDependencies = fromFlag (fetchDeps fetchFlags)     logMsg message rest = debug verbosity message >> rest++    reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)+    independentGoals = fromFlag (fetchIndependentGoals fetchFlags)+    shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)+    maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)   checkTarget :: UserTarget -> IO ()

Distribution/Client/Haddock.hs view

@@ -10,7 +10,7 @@ -- Interfacing with Haddock -- ------------------------------------------------------------------------------module Distribution.Client.Haddock +module Distribution.Client.Haddock     (      regenerateHaddockIndex     )@@ -28,24 +28,22 @@ import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Text (display)-import Distribution.Client.PackageIndex(PackageIndex, allPackages,-                                        allPackagesByName, fromList)+import Distribution.Simple.PackageIndex (PackageIndex, allPackages,+                                         allPackagesByName, fromList) import Distribution.Simple.Utils          ( comparing, intercalate, debug          , installDirectoryContents, withTempDirectory )-import Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.InstalledPackageInfo as InstalledPackageInfo          ( InstalledPackageInfo          , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )-import Distribution.Client.Types-         ( InstalledPackage(..) ) -regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO ()+regenerateHaddockIndex :: Verbosity -> PackageIndex -> ProgramConfiguration -> FilePath -> IO () regenerateHaddockIndex verbosity pkgs conf index = do       (paths,warns) <- haddockPackagePaths pkgs'       case warns of         Nothing -> return ()         Just m  -> debug verbosity m-      +       (confHaddock, _, _) <-           requireProgramVersion verbosity haddockProgram                                     (orLaterVersion (Version [0,6] [])) conf@@ -63,14 +61,13 @@         rawSystemProgram verbosity confHaddock flags         renameFile (tempDir </> "index.html") (tempDir </> destFile)         installDirectoryContents verbosity tempDir destDir-      -  where ++  where     (destDir,destFile) = splitFileName index-    pkgs' = map (maximumBy $ comparing packageId) -            . allPackagesByName +    pkgs' = map (maximumBy $ comparing packageId)+            . allPackagesByName             . fromList             . filter exposed-            . map (\(InstalledPackage pkg _) -> pkg)             . allPackages             $ pkgs

Distribution/Client/HttpUtils.hs view

@@ -5,6 +5,7 @@ module Distribution.Client.HttpUtils (     downloadURI,     getHTTP,+    cabalBrowse,     proxy,     isOldHackageURI   ) where@@ -17,10 +18,10 @@ import Network.Stream          ( Result, ConnError(..) ) import Network.Browser-         ( Proxy (..), Authority (..), browse-         , setOutHandler, setErrHandler, setProxy, request)+         ( Proxy (..), Authority (..), BrowserAction, browse+         , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request) import Control.Monad-         ( mplus, join, liftM2 )+         ( mplus, join, liftM, liftM2 ) import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.ByteString.Lazy (ByteString) #ifdef WIN32@@ -151,15 +152,22 @@  -- |Carry out a GET request, using the local proxy settings getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))-getHTTP verbosity uri = do-                 p   <- proxy verbosity-                 let req = mkRequest uri-                 (_, resp) <- browse $ do-                                setErrHandler (warn verbosity . ("http error: "++))-                                setOutHandler (debug verbosity)-                                setProxy p-                                request req-                 return (Right resp)+getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $+                              cabalBrowse verbosity (return ()) (request (mkRequest uri))++cabalBrowse :: Verbosity+            -> BrowserAction s ()+            -> BrowserAction s a+            -> IO a+cabalBrowse verbosity auth act = do+    p   <- proxy verbosity+    browse $ do+        setProxy p+        setErrHandler (warn verbosity . ("http error: "++))+        setOutHandler (debug verbosity)+        auth+        setAuthorityGen (\_ _ -> return Nothing)+        act  downloadURI :: Verbosity             -> URI      -- ^ What to download

Distribution/Client/IndexUtils.hs view

@@ -12,10 +12,13 @@ ----------------------------------------------------------------------------- module Distribution.Client.IndexUtils (   getInstalledPackages,-  getAvailablePackages,+  getSourcePackages,+  convert,    readPackageIndexFile,-  parseRepoIndex,+  parsePackageIndex,+  readRepoIndex,+  updateRepoIndexCache,   ) where  import qualified Distribution.Client.Tar as Tar@@ -23,7 +26,7 @@  import Distribution.Package          ( PackageId, PackageIdentifier(..), PackageName(..)-         , Package(..), packageVersion+         , Package(..), packageVersion, packageName          , Dependency(Dependency), InstalledPackageId(..) ) import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex@@ -44,53 +47,57 @@ import Distribution.Version          ( Version(Version), intersectVersionRanges ) import Distribution.Text-         ( simpleParse )+         ( display, simpleParse ) import Distribution.Verbosity          ( Verbosity, lessVerbose ) import Distribution.Simple.Utils-         ( warn, info, fromUTF8, equating )+         ( die, warn, info, fromUTF8, equating ) +import Data.Char   (isAlphaNum) import Data.Maybe  (catMaybes, fromMaybe) import Data.List   (isPrefixOf, groupBy) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus), when)+import Control.Monad (MonadPlus(mplus), when, unless, liftM) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath ((</>), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix          ( takeFileName )+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) import System.Directory-         ( getModificationTime )+         ( getModificationTime, doesFileExist ) import System.Time          ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) + getInstalledPackages :: Verbosity -> Compiler                      -> PackageDBStack -> ProgramConfiguration-                     -> IO (PackageIndex InstalledPackage)+                     -> IO InstalledPackageIndex.PackageIndex getInstalledPackages verbosity comp packageDbs conf =-    fmap convert (Configure.getInstalledPackages verbosity'-                                                 comp packageDbs conf)+    Configure.getInstalledPackages verbosity' comp packageDbs conf   where     --FIXME: make getInstalledPackages use sensible verbosity in the first place     verbosity'  = lessVerbose verbosity -    convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage-    convert index = PackageIndex.fromList-      -- There can be multiple installed instances of each package version,-      -- like when the same package is installed in the global & user dbs.-      -- InstalledPackageIndex.allPackagesByName gives us the installed-      -- packages with the most preferred instances first, so by picking the-      -- first we should get the user one. This is almost but not quite the-      -- same as what ghc does.-      [ InstalledPackage ipkg (sourceDeps index ipkg)-      | ipkgs <- InstalledPackageIndex.allPackagesByName index-      , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]-+convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage+convert index' = PackageIndex.fromList+  -- There can be multiple installed instances of each package version,+  -- like when the same package is installed in the global & user dbs.+  -- InstalledPackageIndex.allPackagesByName gives us the installed+  -- packages with the most preferred instances first, so by picking the+  -- first we should get the user one. This is almost but not quite the+  -- same as what ghc does.+  [ InstalledPackage ipkg (sourceDeps index' ipkg)+  | ipkgs <- InstalledPackageIndex.allPackagesByName index'+  , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]+  where     -- The InstalledPackageInfo only lists dependencies by the     -- InstalledPackageId, which means we do not directly know the corresponding     -- source dependency. The only way to find out is to lookup the@@ -109,23 +116,27 @@     brokenPackageId (InstalledPackageId str) =       PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) +------------------------------------------------------------------------+-- Reading the source package index+--+ -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's. ----- All the 'AvailablePackage's are marked as having come from the appropriate+-- All the 'SourcePackage's are marked as having come from the appropriate -- 'Repo'. -- -- This is a higher level wrapper used internally in cabal-install. ---getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb-getAvailablePackages verbosity [] = do+getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb+getSourcePackages verbosity [] = do   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."-  return AvailablePackageDb {+  return SourcePackageDb {     packageIndex       = mempty,     packagePreferences = mempty   }-getAvailablePackages verbosity repos = do+getSourcePackages verbosity repos = do   info verbosity "Reading available packages..."   pkgss <- mapM (readRepoIndex verbosity) repos   let (pkgs, prefs) = mconcat pkgss@@ -133,50 +144,39 @@                  [ (name, range) | Dependency name range <- prefs ]   _ <- evaluate pkgs   _ <- evaluate prefs'-  return AvailablePackageDb {+  return SourcePackageDb {     packageIndex       = pkgs,     packagePreferences = prefs'   } + -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. ----- All the 'AvailablePackage's are marked as having come from the given 'Repo'.+-- All the 'SourcePackage's are marked as having come from the given 'Repo'. -- -- This is a higher level wrapper used internally in cabal-install. -- readRepoIndex :: Verbosity -> Repo-              -> IO (PackageIndex AvailablePackage, [Dependency])-readRepoIndex verbosity repo = handleNotFound $ do+              -> IO (PackageIndex SourcePackage, [Dependency])+readRepoIndex verbosity repo =   let indexFile = repoLocalDir repo </> "00-index.tar"-  (pkgs, prefs) <- either fail return-                 . foldlTarball extract ([], [])-               =<< BS.readFile indexFile+      cacheFile = repoLocalDir repo </> "00-index.cache"+  in handleNotFound $ do+    warnIfIndexIsOld indexFile+    whenCacheOutOfDate indexFile cacheFile $ do+      info verbosity $ "Updating the index cache file..."+      updatePackageIndexCacheFile indexFile cacheFile+    readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile -  pkgIndex <- evaluate $ PackageIndex.fromList-    [ AvailablePackage {+  where+    mkAvailablePackage pkgid pkg =+      SourcePackage {         packageInfoId      = pkgid,         packageDescription = pkg,         packageSource      = RepoTarballPackage repo pkgid Nothing       }-    | (pkgid, pkg) <- pkgs] -  warnIfIndexIsOld indexFile-  return (pkgIndex, prefs)--  where-    extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $-              (do pkg <- extractPkg entry; return (pkg:pkgs, prefs))-      `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs))--    extractPrefs :: Tar.Entry -> Maybe [Dependency]-    extractPrefs entry = case Tar.entryContent entry of-      Tar.NormalFile content _-         | takeFileName (Tar.entryPath entry) == "preferred-versions"-        -> Just . parsePreferredVersions-         . BS.Char8.unpack $ content-      _ -> Nothing-     handleNotFound action = catch action $ \e -> if isDoesNotExistError e       then do         case repoKind repo of@@ -201,12 +201,33 @@           ++ "'cabal update' to get the latest list of available packages."         Right _localRepo -> return () -parsePreferredVersions :: String -> [Dependency]-parsePreferredVersions = catMaybes-                       . map simpleParse-                       . filter (not . isPrefixOf "--")-                       . lines+-- | 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.+--+updateRepoIndexCache :: Verbosity -> Repo -> IO ()+updateRepoIndexCache verbosity repo =+    whenCacheOutOfDate indexFile cacheFile $ do+      info verbosity $ "Updating the index cache file..."+      updatePackageIndexCacheFile indexFile cacheFile+  where+    indexFile = repoLocalDir repo </> "00-index.tar"+    cacheFile = repoLocalDir repo </> "00-index.cache" +whenCacheOutOfDate :: FilePath-> FilePath -> IO () -> IO ()+whenCacheOutOfDate origFile cacheFile action = do+  exists <- doesFileExist cacheFile+  if not exists+    then action+    else do+      origTime  <- getModificationTime origFile+      cacheTime <- getModificationTime cacheFile+      unless (cacheTime >= origTime) action+++------------------------------------------------------------------------+-- Reading the index file+--+ -- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. -- -- This is supposed to be an \"all in one\" way to easily get at the info in@@ -218,23 +239,56 @@ -- readPackageIndexFile :: Package pkg                      => (PackageId -> GenericPackageDescription -> pkg)-                     -> FilePath -> IO (PackageIndex pkg)+                     -> FilePath+                     -> IO (PackageIndex pkg, [Dependency]) readPackageIndexFile mkPkg indexFile = do-  pkgs <- either fail return-        . parseRepoIndex-        . maybeDecompress-      =<< BS.readFile indexFile-  -  evaluate $ PackageIndex.fromList-   [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs]+  (pkgs, prefs) <- either fail return+                 . parsePackageIndex+                 . maybeDecompress+               =<< BS.readFile indexFile +  pkgs' <- evaluate $ PackageIndex.fromList+            [ mkPkg pkgid pkg | (pkgid, pkg, _) <- pkgs]+  return (pkgs', prefs)+ -- | Parse an uncompressed \"00-index.tar\" repository index file represented -- as a 'ByteString'. ---parseRepoIndex :: ByteString-               -> Either String [(PackageId, GenericPackageDescription)]-parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) []+parsePackageIndex :: ByteString+                  -> Either String+                            ( [(PackageId, GenericPackageDescription, BlockNo)]+                            , [Dependency] )+parsePackageIndex = accum 0 [] [] . Tar.read+  where+    accum blockNo pkgs prefs es = case es of+      Tar.Fail err   -> Left  err+      Tar.Done       -> Right (reverse pkgs, reverse prefs)+      Tar.Next e es' -> accum blockNo' pkgs' prefs' es'+        where+          (pkgs', prefs') = extract blockNo pkgs prefs e+          blockNo'        = blockNo + sizeInBlocks e +    extract blockNo pkgs prefs entry =+       fromMaybe (pkgs, prefs) $+                 tryExtractPkg+         `mplus` tryExtractPrefs+      where+        tryExtractPkg = do+          (pkgid, pkg) <- extractPkg entry+          return ((pkgid, pkg, blockNo):pkgs, prefs)++        tryExtractPrefs = do+          prefs' <- extractPrefs entry+          return (pkgs, prefs'++prefs)++    sizeInBlocks entry =+        1 + case Tar.entryContent entry of+              Tar.NormalFile     _   size -> bytesToBlocks size+              Tar.OtherEntryType _ _ size -> bytesToBlocks size+              _                           -> 0+      where+        bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)+ extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) extractPkg entry = case Tar.entryContent entry of   Tar.NormalFile content _@@ -256,10 +310,156 @@   where     fileName = Tar.entryPath entry -foldlTarball :: (a -> Tar.Entry -> a) -> a-             -> ByteString -> Either String a-foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read+extractPrefs :: Tar.Entry -> Maybe [Dependency]+extractPrefs entry = case Tar.entryContent entry of+  Tar.NormalFile content _+     | takeFileName (Tar.entryPath entry) == "preferred-versions"+    -> Just . parsePreferredVersions+     . BS.Char8.unpack $ content+  _ -> Nothing++parsePreferredVersions :: String -> [Dependency]+parsePreferredVersions = catMaybes+                       . map simpleParse+                       . filter (not . isPrefixOf "--")+                       . lines++------------------------------------------------------------------------+-- Reading and updating the index cache+--++updatePackageIndexCacheFile :: FilePath -> FilePath -> IO ()+updatePackageIndexCacheFile indexFile cacheFile = do+    (pkgs, prefs) <- either fail return+                   . parsePackageIndex+                   . maybeDecompress+                 =<< BS.readFile indexFile+    let cache = mkCache pkgs prefs+    writeFile cacheFile (showIndexCache cache)   where-    check _  (Tar.Fail err)  = Left  err-    check ok Tar.Done        = Right ok-    check ok (Tar.Next e es) = check (e:ok) es+    mkCache pkgs prefs =+        [ CachePrefrence pref          | pref <- prefs ]+     ++ [ CachePackageId pkgid blockNo | (pkgid, _, blockNo) <- pkgs ]++readPackageIndexCacheFile :: Package pkg+                          => (PackageId -> GenericPackageDescription -> pkg)+                          -> FilePath+                          -> FilePath+                          -> IO (PackageIndex pkg, [Dependency])+readPackageIndexCacheFile mkPkg indexFile cacheFile = do+  indexHnd <- openFile indexFile ReadMode+  cache    <- liftM readIndexCache (BSS.readFile cacheFile)+  packageIndexFromCache mkPkg indexHnd cache+++packageIndexFromCache :: Package pkg+                      => (PackageId -> GenericPackageDescription -> pkg)+                      -> Handle+                      -> [IndexCacheEntry]+                      -> IO (PackageIndex pkg, [Dependency])+packageIndexFromCache mkPkg hnd = accum mempty []+  where+    accum srcpkgs prefs [] = do+      -- Have to reverse entries, since in a tar file, later entries mask+      -- earlier ones, and PackageIndex.fromList does the same, but we+      -- accumulate the list of entries in reverse order, so need to reverse.+      pkgIndex <- evaluate $ PackageIndex.fromList (reverse srcpkgs)+      return (pkgIndex, prefs)++    accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do+      -- Given the cache entry, make a package index entry.+      -- The magic here is that we use lazy IO to read the .cabal file+      -- from the index tarball if it turns out that we need it.+      -- Most of the time we only need the package id.+      pkg <- unsafeInterleaveIO $ do+               getPackageDescription blockno+      let srcpkg = mkPkg pkgid pkg+      accum (srcpkg:srcpkgs) prefs entries++    accum srcpkgs prefs (CachePrefrence pref : entries) =+      accum srcpkgs (pref:prefs) entries++    getPackageDescription blockno = do+      hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512))+      header  <- BS.hGet hnd 512+      size    <- getEntrySize header+      content <- BS.hGet hnd (fromIntegral size)+      readPackageDescription content++    getEntrySize header =+      case Tar.read header of+        Tar.Next e _ ->+          case Tar.entryContent e of+            Tar.NormalFile _ size -> return size+            _                     -> interror "unexpected tar entry type"+        _ -> interror "could not read tar file entry"++    readPackageDescription content =+      case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+        ParseOk _ d -> return d+        _           -> interror "failed to parse .cabal file"++    interror msg = die $ "internal error when reading package index: " ++ msg+                      ++ "The package index or index cache is probably "+                      ++ "corrupt. Running cabal update might fix it."++------------------------------------------------------------------------+-- Index cache data structure+--++-- | Tar files are block structured with 512 byte blocks. Every header and file+-- content starts on a block boundary.+--+type BlockNo = Int++data IndexCacheEntry = CachePackageId PackageId BlockNo+                     | CachePrefrence Dependency+  deriving (Eq, Show)++readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry+readIndexCacheEntry = \line ->+  case BSS.words line of+    [key, pkgnamestr, pkgverstr, sep, blocknostr]+      | key == packageKey && sep == blocknoKey ->+      case (parseName pkgnamestr, parseVer pkgverstr [], parseBlockNo blocknostr) of+        (Just pkgname, Just pkgver, Just blockno)+          -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)+        _ -> Nothing+    (key: remainder) | key == preferredVersionKey ->+      fmap CachePrefrence (simpleParse (BSS.unpack (BSS.unwords remainder)))+    _  -> Nothing+  where+    packageKey = BSS.pack "pkg:"+    blocknoKey = BSS.pack "b#"+    preferredVersionKey = BSS.pack "pref-ver:"++    parseName str+      | BSS.all (\c -> isAlphaNum c || c == '-') str+                  = Just (PackageName (BSS.unpack str))+      | otherwise = Nothing++    parseVer str vs =+      case BSS.readInt str of+        Nothing        -> Nothing+        Just (v, str') -> case BSS.uncons str' of+          Just ('.', str'') -> parseVer str'' (v:vs)+          Just _            -> Nothing+          Nothing           -> Just (Version (reverse (v:vs)) [])++    parseBlockNo str =+      case BSS.readInt str of+        Just (blockno, remainder) | BSS.null remainder -> Just blockno+        _                                              -> Nothing++showIndexCacheEntry :: IndexCacheEntry -> String+showIndexCacheEntry entry = case entry of+   CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid)+                                  ++ " " ++ display (packageVersion pkgid)+                          ++ " b# " ++ show b+   CachePrefrence dep     -> "pref-ver: " ++ display dep++readIndexCache :: BSS.ByteString -> [IndexCacheEntry]+readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines++showIndexCache :: [IndexCacheEntry] -> String+showIndexCache = unlines . map showIndexCacheEntry

Distribution/Client/Init.hs view

@@ -24,29 +24,45 @@ import System.IO   ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory-  ( getCurrentDirectory )+  ( getCurrentDirectory, doesDirectoryExist )+import System.FilePath+  ( (</>) ) import Data.Time   ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )  import Data.List-  ( intersperse )+  ( intersperse, intercalate, nub, groupBy, (\\) ) import Data.Maybe-  ( fromMaybe, isJust )+  ( fromMaybe, isJust, catMaybes )+import Data.Function+  ( on )+import qualified Data.Map as M import Data.Traversable   ( traverse )+import Control.Applicative+  ( (<$>) ) import Control.Monad   ( when ) #if MIN_VERSION_base(3,0,0) import Control.Monad-  ( (>=>) )+  ( (>=>), join ) #endif+import Control.Arrow+  ( (&&&) ) -import Text.PrettyPrint.HughesPJ hiding (mode, cat)+import Text.PrettyPrint hiding (mode, cat)  import Data.Version   ( Version(..) ) import Distribution.Version-  ( orLaterVersion )+  ( orLaterVersion, withinVersion, VersionRange )+import Distribution.Verbosity+  ( Verbosity )+import Distribution.ModuleName+  ( ModuleName, fromString )+import Distribution.InstalledPackageInfo+  ( InstalledPackageInfo, sourcePackageId, exposed )+import qualified Distribution.Package as P  import Distribution.Client.Init.Types   ( InitFlags(..), PackageType(..), Category(..) )@@ -64,14 +80,30 @@   ( runReadE, readP_to_E ) import Distribution.Simple.Setup   ( Flag(..), flagToMaybe )+import Distribution.Simple.Configure+  ( getInstalledPackages )+import Distribution.Simple.Compiler+  ( PackageDBStack, Compiler )+import Distribution.Simple.Program+  ( ProgramConfiguration )+import Distribution.Simple.PackageIndex+  ( PackageIndex, moduleNameIndex ) import Distribution.Text   ( display, Text(..) ) -initCabal :: InitFlags -> IO ()-initCabal initFlags = do+initCabal :: Verbosity+          -> PackageDBStack+          -> Compiler+          -> ProgramConfiguration+          -> InitFlags+          -> IO ()+initCabal verbosity packageDBs comp conf initFlags = do++  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+   hSetBuffering stdout NoBuffering -  initFlags' <- extendFlags initFlags+  initFlags' <- extendFlags installedPkgIndex initFlags    writeLicense initFlags'   writeSetupFile initFlags'@@ -85,17 +117,19 @@  -- | Fill in more details by guessing, discovering, or prompting the --   user.-extendFlags :: InitFlags -> IO InitFlags-extendFlags =  getPackageName-           >=> getVersion-           >=> getLicense-           >=> getAuthorInfo-           >=> getHomepage-           >=> getSynopsis-           >=> getCategory-           >=> getLibOrExec-           >=> getSrcDir-           >=> getModulesAndBuildTools+extendFlags :: PackageIndex -> InitFlags -> IO InitFlags+extendFlags pkgIx =+      getPackageName+  >=> getVersion+  >=> getLicense+  >=> getAuthorInfo+  >=> getHomepage+  >=> getSynopsis+  >=> getCategory+  >=> getLibOrExec+  >=> getGenComments+  >=> getSrcDir+  >=> getModulesBuildToolsAndDeps pkgIx  -- | Combine two actions which may return a value, preferring the first. That --   is, run the second action only if the first doesn't return a value.@@ -124,11 +158,11 @@    return $ flags { packageName = maybeToFlag pkgName' } --- | Package version: use 0.1 as a last resort, but try prompting the user if---   possible.+-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user+--  if possible. getVersion :: InitFlags -> IO InitFlags getVersion flags = do-  let v = Just $ Version { versionBranch = [0,1], versionTags = [] }+  let v = Just $ Version { versionBranch = [0,1,0,0], versionTags = [] }   v' <-     return (flagToMaybe $ version flags)         ?>> maybePrompt flags (prompt "Package version" v)         ?>> return v@@ -138,11 +172,13 @@ getLicense :: InitFlags -> IO InitFlags getLicense flags = do   lic <-     return (flagToMaybe $ license flags)-         ?>> fmap (fmap (either UnknownLicense id))+         ?>> fmap (fmap (either UnknownLicense id) . join)                   (maybePrompt flags-                    (promptList "Please choose a license"-                                knownLicenses (Just BSD3) True))+                    (promptListOptional "Please choose a license" listedLicenses))   return $ flags { license = maybeToFlag lic }+  where+    listedLicenses =+      knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense]  -- | The author's name and email. Prompt, or try to guess from an existing --   darcs repo.@@ -166,7 +202,7 @@ getHomepage flags = do   hp  <- queryHomepage   hp' <-     return (flagToMaybe $ homepage flags)-         ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp)+         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)          ?>> return hp    return $ flags { homepage = maybeToFlag hp' }@@ -190,8 +226,8 @@ getCategory :: InitFlags -> IO InitFlags getCategory flags = do   cat <-     return (flagToMaybe $ category flags)-         ?>> maybePrompt flags (promptList "Project category" [Codec ..]-                                                              Nothing True)+         ?>> fmap join (maybePrompt flags+                         (promptListOptional "Project category" [Codec ..]))   return $ flags { category = maybeToFlag cat }  -- | Ask whether the project builds a library or executable.@@ -201,42 +237,122 @@            ?>> maybePrompt flags (either (const Library) id `fmap`                                    (promptList "What does the package build"                                                [Library, Executable]-                                               Nothing False))+                                               Nothing display False))            ?>> return (Just Library)    return $ flags { packageType = maybeToFlag isLib } +-- | Ask whether to generate explanitory comments.+getGenComments :: InitFlags -> IO InitFlags+getGenComments flags = do+  genComments <-     return (flagToMaybe $ noComments flags)+                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))+                 ?>> return (Just False)+  return $ flags { noComments = maybeToFlag (fmap not genComments) }+  where+    promptMsg = "Include documentation on what each field means (y/n)"+ -- | Try to guess the source root directory (don't prompt the user). getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do   srcDirs <-     return (sourceDirs flags)-             ?>> guessSourceDirs+             ?>> Just `fmap` (guessSourceDirs flags)    return $ flags { sourceDirs = srcDirs } --- XXX--- | Try to guess source directories.-guessSourceDirs :: IO (Maybe [String])-guessSourceDirs = return Nothing+-- | Try to guess source directories.  Could try harder; for the+--   moment just looks to see whether there is a directory called 'src'.+guessSourceDirs :: InitFlags -> IO [String]+guessSourceDirs flags = do+  dir      <- fromMaybe getCurrentDirectory+                (fmap return . flagToMaybe $ packageDir flags)+  srcIsDir <- doesDirectoryExist (dir </> "src")+  if srcIsDir+    then return ["src"]+    else return []  -- | Get the list of exposed modules and extra tools needed to build them.-getModulesAndBuildTools :: InitFlags -> IO InitFlags-getModulesAndBuildTools flags = do+getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags+getModulesBuildToolsAndDeps pkgIx flags = do   dir <- fromMaybe getCurrentDirectory                    (fmap return . flagToMaybe $ packageDir flags)    -- XXX really should use guessed source roots.   sourceFiles <- scanForModules dir -  mods <-      return (exposedModules flags)+  Just mods <-      return (exposedModules flags)            ?>> (return . Just . map moduleName $ sourceFiles)    tools <-     return (buildTools flags)            ?>> (return . Just . neededBuildPrograms $ sourceFiles) -  return $ flags { exposedModules = mods-                 , buildTools     = tools }+  deps <-      return (dependencies flags)+           ?>> Just <$> importsToDeps flags+                        (fromString "Prelude" : concatMap imports sourceFiles)+                        pkgIx +  return $ flags { exposedModules = Just mods+                 , buildTools     = tools+                 , dependencies   = deps+                 }++importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency]+importsToDeps flags mods pkgIx = do++  let modMap :: M.Map ModuleName [InstalledPackageInfo]+      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx++      modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]+      modDeps = map (id &&& flip M.lookup modMap) mods++  message flags "\nGuessing dependencies..."+  nub . catMaybes <$> mapM (chooseDep flags) modDeps++-- Given a module and a list of installed packages providing it,+-- choose a dependency (i.e. package + version range) to use for that+-- module.+chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])+          -> IO (Maybe P.Dependency)++chooseDep flags (m, Nothing)+  = message flags ("\nWarning: no package found providing " ++ display m ++ ".")+    >> return Nothing++chooseDep flags (m, Just [])+  = message flags ("\nWarning: no package found providing " ++ display m ++ ".")+    >> return Nothing++    -- We found some packages: group them by name.+chooseDep flags (m, Just ps)+  = case pkgGroups of+      -- if there's only one group, i.e. multiple versions of a single package,+      -- we make it into a dependency, choosing the latest-ish version (see toDep).+      [grp] -> Just <$> toDep grp+      -- otherwise, we refuse to choose between different packages and make the user+      -- do it.+      grps  -> do message flags ("\nWarning: multiple packages found providing "+                                 ++ display m+                                 ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps))+                  message flags ("You will need to pick one and manually add it to the Build-depends: field.")+                  return Nothing+  where+    pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps)++    -- Given a list of available versions of the same package, pick a dependency.+    toDep :: [P.PackageIdentifier] -> IO P.Dependency++    -- If only one version, easy.  We change e.g. 0.4.2  into  0.4.*+    toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize . P.pkgVersion $ pid)++    -- Otherwise, choose the latest version and issue a warning.+    toDep pids  = do+      message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.")+      return $ P.Dependency (P.pkgName . head $ pids)+                            (pvpize . maximum . map P.pkgVersion $ pids)++    pvpize :: Version -> VersionRange+    pvpize v = withinVersion $ v { versionBranch = take 2 (versionBranch v) }+ --------------------------------------------------------------------------- --  Prompting/user interaction  ------------------------------------------- ---------------------------------------------------------------------------@@ -254,6 +370,18 @@ promptStr :: String -> Maybe String -> IO String promptStr = promptDefault' Just id +-- | Create a yes/no prompt with optional default value.+--+promptYesNo :: String -> Maybe Bool -> IO Bool+promptYesNo =+    promptDefault' recogniseYesNo showYesNo+  where+    recogniseYesNo s | s == "y" || s == "Y" = Just True+                     | s == "n" || s == "N" = Just False+                     | otherwise            = Nothing+    showYesNo True  = "y"+    showYesNo False = "n"+ -- | Create a prompt with optional default value that returns a value --   of some Text instance. prompt :: Text t => String -> Maybe t -> IO t@@ -280,34 +408,46 @@ -- | Create a prompt from a prompt string and a String representation --   of an optional default value. mkDefPrompt :: String -> Maybe String -> String-mkDefPrompt pr def = pr ++ defStr def ++ "? "-  where defStr Nothing  = ""-        defStr (Just s) = " [default \"" ++ s ++ "\"]"+mkDefPrompt pr def = pr ++ "?" ++ defStr def+  where defStr Nothing  = " "+        defStr (Just s) = " [default: " ++ s ++ "] " +promptListOptional :: (Text t, Eq t)+                   => String            -- ^ prompt+                   -> [t]               -- ^ choices+                   -> IO (Maybe (Either String t))+promptListOptional pr choices =+    fmap rearrange+  $ promptList pr (Nothing : map Just choices) (Just Nothing)+               (maybe "(none)" display) True+  where+    rearrange = either (Just . Left) (maybe Nothing (Just . Right))+ -- | Create a prompt from a list of items.-promptList :: (Text t, Eq t)+promptList :: Eq t            => String            -- ^ prompt            -> [t]               -- ^ choices            -> Maybe t           -- ^ optional default value+           -> (t -> String)     -- ^ show an item            -> Bool              -- ^ whether to allow an 'other' option            -> IO (Either String t)-promptList pr choices def other = do+promptList pr choices def displayItem other = do   putStrLn $ pr ++ ":"-  let options1 = map (\c -> (Just c == def, display c)) choices+  let options1 = map (\c -> (Just c == def, displayItem c)) choices       options2 = zip ([1..]::[Int])                      (options1 ++ if other then [(False, "Other (specify)")]                                            else [])   mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2-  promptList' (length options2) choices def other+  promptList' displayItem (length options2) choices def other  where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest                       | otherwise = " " ++ star i ++ rest                   where rest = show n ++ ") "                         star True = "*"                         star False = " " -promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t)-promptList' numChoices choices def other = do-  putStr $ mkDefPrompt "Your choice" (display `fmap` def)+promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)+promptList' displayItem numChoices choices def other = do+  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)   inp <- getLine   case (inp, def) of     ("", Just d) -> return $ Right d@@ -315,7 +455,7 @@             Nothing -> invalidChoice inp             Just n  -> getChoice n  where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."-                              promptList' numChoices choices def other+                              promptList' displayItem numChoices choices def other        getChoice n | n < 1 || n > numChoices = invalidChoice (show n)                    | n < numChoices ||                      (n == numChoices && not other)@@ -333,7 +473,7 @@  writeLicense :: InitFlags -> IO () writeLicense flags = do-  message flags "Generating LICENSE..."+  message flags "\nGenerating LICENSE..."   year <- getYear   let licenseFile =         case license flags of@@ -379,6 +519,8 @@     , "main = defaultMain"     ] +-- XXX ought to do something sensible if a .cabal file already exists,+-- instead of overwriting. writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do   message flags "Error: no package name provided."@@ -398,105 +540,114 @@ --   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 = render $+generateCabalFile fileName c =+  renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $   (if (minimal c /= Flag True)-    then showComment (Just $ fileName ++ " auto-generated by cabal init.  For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.")+    then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "+                          ++ "init.  For further documentation, see "+                          ++ "http://haskell.org/cabal/users-guide/")+         $$ text ""     else empty)   $$-  vcat [ fieldS "Name"          (packageName   c)+  vcat [ fieldS "name"          (packageName   c)                 (Just "The name of the package.")                 True -       , field  "Version"       (version       c)-                (Just "The package version.  See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.")+       , field  "version"       (version       c)+                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttp://www.haskell.org/haskellwiki/Package_versioning_policy\n"+                ++ "PVP summary:      +-+------- breaking API changes\n"+                ++ "                  | | +----- non-breaking API additions\n"+                ++ "                  | | | +--- code changes with no API change")                 True -       , fieldS "Synopsis"      (synopsis      c)+       , fieldS "synopsis"      (synopsis      c)                 (Just "A short (one-line) description of the package.")                 True -       , fieldS "Description"   NoFlag+       , fieldS "description"   NoFlag                 (Just "A longer description of the package.")                 True -       , fieldS "Homepage"      (homepage     c)+       , fieldS "homepage"      (homepage     c)                 (Just "URL for the project homepage or repository.")                 False -       , fieldS "Bug-reports"   NoFlag+       , fieldS "bug-reports"   NoFlag                 (Just "A URL where users can report bugs.")                 False -       , field  "License"       (license      c)+       , field  "license"       (license      c)                 (Just "The license under which the package is released.")                 True -       , fieldS "License-file" (Flag "LICENSE")+       , fieldS "license-file" (Flag "LICENSE")                 (Just "The file containing the license text.")                 True -       , fieldS "Author"        (author       c)+       , fieldS "author"        (author       c)                 (Just "The package author(s).")                 True -       , fieldS "Maintainer"    (email        c)+       , fieldS "maintainer"    (email        c)                 (Just "An email address to which users can send suggestions, bug reports, and patches.")                 True -       , fieldS "Copyright"     NoFlag+       , fieldS "copyright"     NoFlag                 (Just "A copyright notice.")                 True -       , fieldS "Category"      (either id display `fmap` category c)+       , fieldS "category"      (either id display `fmap` category c)                 Nothing                 True -       , fieldS "Build-type"    (Flag "Simple")+       , fieldS "build-type"    (Flag "Simple")                 Nothing                 True -       , fieldS "Extra-source-files" NoFlag+       , fieldS "extra-source-files" NoFlag                 (Just "Extra files to be distributed with the package, such as examples or a README.")-                True+                False -       , field  "Cabal-version" (Flag $ orLaterVersion (Version [1,2] []))+       , field  "cabal-version" (Flag $ orLaterVersion (Version [1,8] []))                 (Just "Constraint on the version of Cabal needed to build this package.")                 False         , case packageType c of            Flag Executable ->-             text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat-             [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True+             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat+             [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True -             , generateBuildInfo c+             , generateBuildInfo Executable c              ])-           Flag Library    -> text "\nLibrary" $$ (nest 2 $ vcat-             [ fieldS "Exposed-modules" (listField (exposedModules c))+           Flag Library    -> text "\nlibrary" $$ (nest 2 $ vcat+             [ fieldS "exposed-modules" (listField (exposedModules c))                       (Just "Modules exported by the library.")                       True -             , generateBuildInfo c+             , generateBuildInfo Library c              ])            _               -> empty        ]  where-   generateBuildInfo :: InitFlags -> Doc-   generateBuildInfo c' = vcat-     [ fieldS "Build-depends" (listField (dependencies c'))-              (Just "Packages needed in order to build this package.")+   generateBuildInfo :: PackageType -> InitFlags -> Doc+   generateBuildInfo pkgtype 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.")               True -     , fieldS "Other-modules" (listField (otherModules c'))-              (Just "Modules not exported by this package.")+     , fieldS "build-depends" (listField (dependencies c'))+              (Just "Other library packages from which modules are imported.")               True       , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))-              (Just "Directories other than the root containing source files.")+              (Just "Directories containing source files.")               False -     , fieldS "Build-tools" (listFieldS (buildTools c'))+     , fieldS "build-tools" (listFieldS (buildTools c'))               (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")-              True+              False      ]     listField :: Text s => Maybe [s] -> Flag String@@ -531,8 +682,20 @@    showComment :: Maybe String -> Doc    showComment (Just t) = vcat . map text                         . map ("-- "++) . lines-                        . render . fsep . map text . words $ t+                        . renderStyle style {+                            lineLength = 76,+                            ribbonsPerLine = 1.05+                          }+                        . vcat+                        . map (fcat . map text . breakLine)+                        . lines+                        $ t    showComment Nothing  = text ""++   breakLine  [] = []+   breakLine  cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs'+   breakLine' [] = []+   breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs'  -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO ()

Distribution/Client/Init/Heuristics.hs view

@@ -19,8 +19,10 @@     guessAuthorNameMail,     knownCategories, ) where-import Distribution.Simple.Setup(Flag(..))-import Distribution.ModuleName ( ModuleName, fromString )+import Distribution.Text         (simpleParse)+import Distribution.Simple.Setup (Flag(..))+import Distribution.ModuleName+    ( ModuleName, fromString, toFilePath ) import Distribution.Client.PackageIndex     ( allPackagesByName ) import qualified Distribution.PackageDescription as PD@@ -28,12 +30,13 @@ import Distribution.Simple.Utils          ( intercalate ) -import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) )+import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) ) import Control.Monad (liftM ) import Data.Char   ( isUpper, isLower, isSpace ) #if MIN_VERSION_base(3,0,3) import Data.Either ( partitionEithers ) #endif+import Data.List   ( isPrefixOf ) import Data.Maybe  ( catMaybes ) import Data.Monoid ( mempty, mappend ) import qualified Data.Set as Set ( fromList, toList )@@ -41,7 +44,7 @@                           getHomeDirectory, canonicalizePath ) import System.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension,-                         (</>), splitDirectories, makeRelative )+                         (</>), (<.>), splitDirectories, makeRelative )  -- |Guess the package name based on the given root directory guessPackageName :: FilePath -> IO String@@ -50,10 +53,15 @@ -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry     { relativeSourcePath :: FilePath-    , moduleName :: ModuleName-    , fileExtension :: String+    , moduleName         :: ModuleName+    , fileExtension      :: String+    , imports            :: [ModuleName]     } deriving Show +sfToFileName :: FilePath -> SourceFileEntry -> FilePath+sfToFileName projectRoot (SourceFileEntry relPath m ext _)+  = projectRoot </> relPath </> toFilePath m <.> ext+ -- |Search for source files in the given directory -- and return pairs of guessed haskell source path and -- module names.@@ -69,14 +77,15 @@         let modules = catMaybes [ guessModuleName hierarchy file                                 | file <- files                                 , isUpper (head file) ]+        modules' <- mapM (findImports projectRoot) modules         recMods <- mapM (scanRecursive dir hierarchy) dirs-        return $ concat (modules : recMods)+        return $ concat (modules' : recMods)     tagIsDir parent entry = do         isDir <- doesDirectoryExist (parent </> entry)         return $ (if isDir then Right else Left) entry     guessModuleName hierarchy entry         | takeBaseName entry == "Setup" = Nothing-        | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext+        | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext []         | otherwise = Nothing       where         relRoot = makeRelative projectRoot srcRoot@@ -91,6 +100,35 @@     ignoreDir ('.':_)  = True     ignoreDir dir      = dir `elem` ["dist", "_darcs"] +findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry+findImports projectRoot sf = do+  s <- readFile (sfToFileName projectRoot sf)++  let modules = catMaybes+              . map ( getModName+                    . drop 1+                    . filter (not . null)+                    . dropWhile (/= "import")+                    . words+                    )+              . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering+              . lines+              $ s++      -- XXX we should probably make a better attempt at parsing+      -- comments above.  Unfortunately we can't use a full-fledged+      -- Haskell parser since cabal's dependencies must be kept at a+      -- minimum.++  return sf { imports = modules }++ where getModName :: [String] -> Maybe ModuleName+       getModName []               = Nothing+       getModName ("qualified":ws) = getModName ws+       getModName (ms:_)           = simpleParse ms+++ -- Unfortunately we cannot use the version exported by Distribution.Simple.Program knownSuffixHandlers :: [(String,String)] knownSuffixHandlers =@@ -134,9 +172,9 @@     authorRepoFile  = "_darcs" </> "prefs" </> "author"  -- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached-knownCategories :: AvailablePackageDb -> [String]-knownCategories (AvailablePackageDb available _) = nubSet $-    [ cat | pkg <- map head (allPackagesByName available)+knownCategories :: SourcePackageDb -> [String]+knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $+    [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)           , let catList = (PD.category . PD.packageDescription . packageDescription) pkg           , cat <- splitString ',' catList     ]

Distribution/Client/Init/Licenses.hs view

@@ -12,7 +12,7 @@  bsd3 :: String -> String -> License bsd3 authors year = unlines-    [ "Copyright (c)" ++ year ++ ", " ++ authors+    [ "Copyright (c) " ++ year ++ ", " ++ authors     , ""     , "All rights reserved."     , ""

Distribution/Client/Init/Types.hs view

@@ -18,6 +18,7 @@   ( Flag(..) )  import Distribution.Version+import Distribution.Verbosity import qualified Distribution.Package as P import Distribution.License import Distribution.ModuleName@@ -59,6 +60,8 @@               , dependencies :: Maybe [P.Dependency]               , sourceDirs   :: Maybe [String]               , buildTools   :: Maybe [String]++              , initVerbosity :: Flag Verbosity               }   deriving (Show) @@ -91,6 +94,7 @@     , dependencies   = mempty     , sourceDirs     = mempty     , buildTools     = mempty+    , initVerbosity  = mempty     }   mappend  a b = InitFlags     { nonInteractive = combine nonInteractive@@ -113,6 +117,7 @@     , dependencies   = combine dependencies     , sourceDirs     = combine sourceDirs     , buildTools     = combine buildTools+    , initVerbosity  = combine initVerbosity     }     where combine field = field a `mappend` field b

Distribution/Client/Install.hs view

@@ -19,9 +19,9 @@   ) where  import Data.List-         ( unfoldr, find, nub, sort )+         ( unfoldr, nub, sort, (\\) ) import Data.Maybe-         ( isJust, fromMaybe )+         ( isJust, fromMaybe, maybeToList ) import Control.Exception as Exception          ( handleJust ) #if MIN_VERSION_base(4,0,0)@@ -42,17 +42,19 @@ import System.FilePath          ( (</>), (<.>), takeDirectory ) import System.IO-         ( openFile, IOMode(AppendMode) )+         ( openFile, IOMode(AppendMode), stdout, hFlush ) import System.IO.Error          ( isDoesNotExistError, ioeGetFileName )  import Distribution.Client.Targets import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types+         ( Solver(..) ) import Distribution.Client.FetchUtils import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) -- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, getInstalledPackages )+         ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup@@ -62,7 +64,7 @@ import Distribution.Client.Config          ( defaultCabalDir ) import Distribution.Client.Tar (extractTarGzFile)-import Distribution.Client.Types as Available+import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.SetupWrapper@@ -74,6 +76,7 @@          ( symlinkBinaries ) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World+import qualified Distribution.InstalledPackageInfo as Installed import Paths_cabal_install (getBinDir)  import Distribution.Simple.Compiler@@ -81,14 +84,15 @@          , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Setup-         ( haddockCommand, HaddockFlags(..), emptyHaddockFlags+         ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Cabal-         ( installCommand, InstallFlags(..), emptyInstallFlags )+         ( installCommand, InstallFlags(..), emptyInstallFlags+         , emptyTestFlags, testCommand ) import Distribution.Simple.Utils          ( rawSystemExit, comparing ) import Distribution.Simple.InstallDirs as InstallDirs@@ -97,16 +101,17 @@ import Distribution.Package          ( PackageIdentifier, packageName, packageVersion          , Package(..), PackageFixedDeps(..)-         , Dependency(..), thisPackageVersion )+         , Dependency(..), thisPackageVersion, InstalledPackageId ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription-         ( PackageDescription )+         ( PackageDescription, GenericPackageDescription(..), Flag(..)+         , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration          ( finalizePackageDescription ) import Distribution.Version          ( Version, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils-         ( notice, info, debug, warn, die, intercalate, withTempDirectory )+         ( notice, info, warn, die, intercalate, withTempDirectory ) import Distribution.Client.Utils          ( inDir, mergeBy, MergeResult(..) ) import Distribution.System@@ -114,7 +119,7 @@ import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-         ( Verbosity, showForCabal, verbose )+         ( Verbosity, showForCabal, verbose, deafening ) import Distribution.Simple.BuildPaths ( exeExtension )  --TODO:@@ -145,45 +150,53 @@   -> ConfigFlags   -> ConfigExFlags   -> InstallFlags+  -> HaddockFlags   -> [UserTarget]   -> IO () install verbosity packageDBs repos comp conf-  globalFlags configFlags configExFlags installFlags userTargets0 = do+  globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do -    installed     <- getInstalledPackages verbosity comp packageDBs conf-    availableDb   <- getAvailablePackages verbosity repos+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos +    solver <- chooseSolver verbosity (fromFlag (configSolver  configExFlags)) (compilerId comp)+     let -- For install, if no target is given it means we use the         -- current directory as the single target         userTargets | null userTargets0 = [UserTargetLocalDir "."]                     | otherwise         = userTargets0      pkgSpecifiers <- resolveUserTargets verbosity-                       globalFlags (packageIndex availableDb) userTargets+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       userTargets      notice verbosity "Resolving dependencies..."     installPlan   <- foldProgress logMsg die return $                        planPackages-                         comp configFlags configExFlags installFlags-                         installed availableDb pkgSpecifiers+                         comp solver configFlags configExFlags installFlags+                         installedPkgIndex sourcePkgDb pkgSpecifiers -    printPlanMessages verbosity installed installPlan dryRun+    checkPrintPlan verbosity installedPkgIndex installPlan installFlags pkgSpecifiers      unless dryRun $ do       installPlan' <- performInstallations verbosity-                        context installed installPlan+                        context installedPkgIndex installPlan       postInstallActions verbosity context userTargets installPlan'    where     context :: InstallContext     context = (packageDBs, repos, comp, conf,-               globalFlags, configFlags, configExFlags, installFlags)+               globalFlags, configFlags, configExFlags, installFlags, haddockFlags)      dryRun      = fromFlag (installDryRun installFlags)-    logMsg message rest = debug verbosity message >> rest-+    logMsg message rest = debugNoWrap message >> rest+    -- Solver debug output really looks better without automatic+    -- line wrapping. TODO: This should probably be moved into+    -- the utilities module.+    debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout) -upgrade _ _ _ _ _ _ _ _ _ _ = die $+upgrade _ _ _ _ _ _ _ _ _ _ _ = die $     "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 "@@ -203,25 +216,28 @@                       , GlobalFlags                       , ConfigFlags                       , ConfigExFlags-                      , InstallFlags )+                      , InstallFlags+                      , HaddockFlags )  -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------  planPackages :: Compiler+             -> Solver              -> ConfigFlags              -> ConfigExFlags              -> InstallFlags-             -> PackageIndex InstalledPackage-             -> AvailablePackageDb-             -> [PackageSpecifier AvailablePackage]+             -> PackageIndex+             -> SourcePackageDb+             -> [PackageSpecifier SourcePackage]              -> Progress String String InstallPlan-planPackages comp configFlags configExFlags installFlags-             installed availableDb pkgSpecifiers =+planPackages comp solver configFlags configExFlags installFlags+             installedPkgIndex sourcePkgDb pkgSpecifiers =          resolveDependencies           buildPlatform (compilerId comp)+          solver           resolverParams      >>= if onlyDeps then adjustPlanOnlyDeps else return@@ -229,7 +245,18 @@   where     resolverParams = -        setPreferenceDefault (if upgradeDeps then PreferAllLatest+        setMaxBackjumps (if maxBackjumps < 0 then Nothing+                                             else Just maxBackjumps)++      . setIndependentGoals independentGoals++      . setReorderGoals reorderGoals++      . setAvoidReinstalls avoidReinstalls++      . setShadowPkgs shadowPkgs++      . setPreferenceDefault (if upgradeDeps then PreferAllLatest                                              else PreferLatestForSelected)        . addPreferences@@ -239,32 +266,39 @@        . addConstraints           -- version constraints from the config file or command line-          [ PackageVersionConstraint name ver-          | Dependency name ver <- configConstraints configFlags ]+            (map userToPackageConstraint (configExConstraints configExFlags))        . addConstraints           --FIXME: this just applies all flags to all targets which           -- is silly. We should check if the flags are appropriate-          [ PackageFlagsConstraint (pkgSpecifierTarget pkgSpecifier) flags+          [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags           | let flags = configConfigurationsFlags configFlags           , not (null flags)           , pkgSpecifier <- pkgSpecifiers ] +      . addConstraints+          [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas+          | pkgSpecifier <- pkgSpecifiers ]+       . (if reinstall then reinstallTargets else id) -      $ standardInstallPolicy installed availableDb pkgSpecifiers+      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers +    stanzas = concat+        [ if testsEnabled then [TestStanzas] else []+        , if benchmarksEnabled then [BenchStanzas] else []+        ]+    testsEnabled = fromFlagOrDefault False $ configTests configFlags+    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags+     --TODO: this is a general feature and should be moved to D.C.Dependency     -- Also, the InstallPlan.remove should return info more precise to the     -- problem, rather than the very general PlanProblem type.     adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan     adjustPlanOnlyDeps =         either (Fail . explain) Done-      . InstallPlan.remove isTarget+      . InstallPlan.remove (isTarget pkgSpecifiers)       where-        isTarget pkg = packageName pkg `elem` targetnames-        targetnames  = map pkgSpecifierTarget pkgSpecifiers-                 explain :: [InstallPlan.PlanProblem] -> String         explain problems =             "Cannot select only the dependencies (as requested by the "@@ -281,74 +315,210 @@                   , depid <- depids                   , packageName depid `elem` targetnames ] -    reinstall   = fromFlag (installReinstall installFlags)-    upgradeDeps = fromFlag (installUpgradeDeps installFlags)-    onlyDeps    = fromFlag (installOnlyDeps installFlags)+        targetnames  = map pkgSpecifierTarget pkgSpecifiers ++    reinstall        = fromFlag (installReinstall        installFlags)+    reorderGoals     = fromFlag (installReorderGoals     installFlags)+    independentGoals = fromFlag (installIndependentGoals installFlags)+    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)+    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)+    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)+    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)+    onlyDeps         = fromFlag (installOnlyDeps         installFlags)+ -- ------------------------------------------------------------ -- * Informational messages -- ------------------------------------------------------------ -printPlanMessages :: Verbosity-                  -> PackageIndex InstalledPackage-                  -> InstallPlan-                  -> Bool-                  -> IO ()-printPlanMessages verbosity installed installPlan dryRun = do+-- | Perform post-solver checks of the install plan and print it if+-- either requested or needed.+checkPrintPlan :: Verbosity+               -> PackageIndex+               -> InstallPlan+               -> InstallFlags+               -> [PackageSpecifier SourcePackage]+               -> IO ()+checkPrintPlan verbosity installed installPlan installFlags pkgSpecifiers = do +  -- User targets that are already installed.+  let preExistingTargets =+        [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers,+              InstallPlan.PreExisting p <- InstallPlan.toList installPlan,+              packageName p `elem` tgts ]++  -- If there's nothing to install, we print the already existing+  -- target packages as an explanation.   when nothingToInstall $-    notice verbosity $-         "No packages to be installed. All the requested packages are "-      ++ "already installed.\n If you want to reinstall anyway then use "-      ++ "the --reinstall flag."+    notice verbosity $ unlines $+         "All the requested packages are already installed:"+       : map (display . packageId) preExistingTargets+      ++ ["Use --reinstall if you want to reinstall anyway."] -  when (dryRun || verbosity >= verbose) $-    printDryRun verbosity installed installPlan+  let lPlan = linearizeInstallPlan installed installPlan+  -- Are any packages classified as reinstalls?+  let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan+  -- Packages that are already broken.+  let oldBrokenPkgs =+          map Installed.installedPackageId+        . PackageIndex.reverseDependencyClosure installed+        . map (Installed.installedPackageId . fst)+        . PackageIndex.brokenPackages+        $ installed+  let excluded = reinstalledPkgs ++ oldBrokenPkgs+  -- Packages that are reverse dependencies of replaced packages are very+  -- likely to be broken. We exclude packages that are already broken.+  let newBrokenPkgs =+        filter (\ p -> not (Installed.installedPackageId p `elem` excluded))+               (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)+  let containsReinstalls = not (null reinstalledPkgs)+  let breaksPkgs         = not (null newBrokenPkgs) +  let adaptedVerbosity+        | containsReinstalls && not overrideReinstall = verbosity `max` verbose+        | otherwise                                   = verbosity++  -- We print the install plan if we are in a dry-run or if we are confronted+  -- with a dangerous install plan.+  when (dryRun || containsReinstalls && not overrideReinstall) $+    printPlan (dryRun || breaksPkgs && not overrideReinstall) adaptedVerbosity lPlan++  -- If the install plan is dangerous, we print various warning messages. In+  -- particular, if we can see that packages are likely to be broken, we even+  -- bail out (unless installation has been forced with --force-reinstalls).+  when containsReinstalls $ do+    if breaksPkgs+      then do+        (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $+            "The following packages are likely to be broken by the reinstalls:"+          : map (display . Installed.sourcePackageId) newBrokenPkgs+          ++ if overrideReinstall+               then if dryRun then [] else+                 ["Continuing even though the plan contains dangerous reinstalls."]+               else+                 ["Use --force-reinstalls if you want to install anyway."]+      else unless dryRun $ warn verbosity+             "Note that reinstalls are always dangerous. Continuing anyway..."+   where     nothingToInstall = null (InstallPlan.ready installPlan) +    dryRun            = fromFlag (installDryRun            installFlags)+    overrideReinstall = fromFlag (installOverrideReinstall installFlags) -printDryRun :: Verbosity-            -> PackageIndex InstalledPackage-            -> InstallPlan-            -> IO ()-printDryRun verbosity installed plan = case unfoldr next plan of-  []   -> return ()-  pkgs-    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $-        "In order, the following would be installed:"-      : map showPkgAndReason pkgs-    | otherwise -> notice verbosity $ unlines $-        "In order, the following would be installed (use -v for more details):"-      : map (display . packageId) pkgs+linearizeInstallPlan :: PackageIndex+                     -> InstallPlan+                     -> [(ConfiguredPackage, PackageStatus)]+linearizeInstallPlan installedPkgIndex plan = unfoldr next plan   where     next plan' = case InstallPlan.ready plan' of       []      -> Nothing-      (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')-        where pkgid = packageId pkg+      (pkg:_) -> Just ((pkg, status), InstallPlan.completed pkgid result plan')+        where pkgid  = packageId pkg+              status = packageStatus installedPkgIndex pkg               result = BuildOk DocsNotTried TestsNotTried               --FIXME: This is a bit of a hack,               -- pretending that each package is installed -    showPkgAndReason pkg' = display (packageId pkg') ++ " " ++-          case PackageIndex.lookupPackageName installed (packageName pkg') of-            [] -> "(new package)"-            ps ->  case find ((==packageId pkg') . packageId) ps of-              Nothing  -> "(new version)"-              Just pkg -> "(reinstall)" ++ case changes pkg pkg' of-                []   -> ""-                diff -> " changes: "  ++ intercalate ", " diff-    changes pkg pkg' = map change . filter changed+data PackageStatus = NewPackage+                   | NewVersion [Version]+                   | Reinstall  [InstalledPackageId] [PackageChange]++type PackageChange = MergeResult PackageIdentifier PackageIdentifier++isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool+isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames+  where+    targetnames  = map pkgSpecifierTarget pkgSpecifiers++extractReinstalls :: PackageStatus -> [InstalledPackageId]+extractReinstalls (Reinstall ipids _) = ipids+extractReinstalls _                   = []++packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus+packageStatus installedPkgIndex cpkg =+  case PackageIndex.lookupPackageName installedPkgIndex+                                      (packageName cpkg) of+    [] -> NewPackage+    ps ->  case filter ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of+      []           -> NewVersion (map fst ps)+      pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)+                                (changes pkg cpkg)++  where++    changes :: Installed.InstalledPackageInfo+            -> ConfiguredPackage+            -> [MergeResult PackageIdentifier PackageIdentifier]+    changes pkg pkg' = filter changed                      $ mergeBy (comparing packageName)-                         (nub . sort . depends $ pkg)+                         -- get dependencies of installed package (convert to source pkg ids via index)+                         (nub . sort . concatMap (maybeToList .+                                                  fmap Installed.sourcePackageId .+                                                  PackageIndex.lookupInstalledPackageId installedPkgIndex) .+                                                  Installed.depends $ pkg)+                         -- get dependencies of configured package                          (nub . sort . depends $ pkg')++    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'+    changed _                        = True++printPlan :: Bool -- is dry run+          -> Verbosity+          -> [(ConfiguredPackage, PackageStatus)]+          -> IO ()+printPlan dryRun verbosity plan = case plan of+  []   -> return ()+  pkgs+    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $+        ("In order, the following " ++ wouldWill ++ " be installed:")+      : map showPkgAndReason pkgs+    | otherwise -> notice verbosity $ unlines $+        ("In order, the following " ++ wouldWill ++ " be installed (use -v for more details):")+      : map (display . packageId) (map fst pkgs)+  where+    wouldWill | dryRun    = "would"+              | otherwise = "will"++    showPkgAndReason (pkg', pr) = display (packageId pkg') +++          showFlagAssignment (nonDefaultFlags pkg') +++          showStanzas (stanzas pkg') ++ " " +++          case pr of+            NewPackage     -> "(new package)"+            NewVersion _   -> "(new version)"+            Reinstall _ cs -> "(reinstall)" ++ case cs of+                []   -> ""+                diff -> " changes: "  ++ intercalate ", " (map change diff)++    toFlagAssignment :: [Flag] -> FlagAssignment+    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))++    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment+    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =+      let defaultAssignment =+            toFlagAssignment+             (genPackageFlags (Source.packageDescription spkg))+      in  fa \\ defaultAssignment++    stanzas :: ConfiguredPackage -> [OptionalStanza]+    stanzas (ConfiguredPackage _ _ sts _) = sts++    showStanzas :: [OptionalStanza] -> String+    showStanzas = concatMap ((' ' :) . showStanza)+    showStanza TestStanzas  = "*test"+    showStanza BenchStanzas = "*bench"++    -- FIXME: this should be a proper function in a proper place+    showFlagAssignment :: FlagAssignment -> String+    showFlagAssignment = concatMap ((' ' :) . showFlagValue)+    showFlagValue (f, True)   = '+' : showFlagName f+    showFlagValue (f, False)  = '-' : showFlagName f+    showFlagName (FlagName f) = f+     change (OnlyInLeft pkgid)        = display pkgid ++ " removed"     change (InBoth     pkgid pkgid') = display pkgid ++ " -> "                                     ++ display (packageVersion pkgid')     change (OnlyInRight      pkgid') = display pkgid' ++ " added"-    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'-    changed _                        = True  -- ------------------------------------------------------------ -- * Post installation stuff@@ -369,7 +539,7 @@                    -> InstallPlan                    -> IO () postInstallActions verbosity-  (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags)+  (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _)   targets installPlan = do    unless oneShot $@@ -458,8 +628,8 @@      "Updating documentation index " ++ indexFile    --TODO: might be nice if the install plan gave us the new InstalledPackageInfo-  installed <- getInstalledPackages verbosity comp packageDBs conf-  Haddock.regenerateHaddockIndex verbosity installed conf indexFile+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile    | otherwise = return ()   where@@ -542,6 +712,8 @@                         ++ " The exception was:\n  " ++ show e       BuildFailed     e -> " failed during the building phase."                         ++ " The exception was:\n  " ++ show e+      TestsFailed     e -> " failed during the tests phase."+                        ++ " The exception was:\n  " ++ show e       InstallFailed   e -> " failed during the final install step."                         ++ " The exception was:\n  " ++ show e @@ -557,21 +729,22 @@  performInstallations :: Verbosity                      -> InstallContext-                     -> PackageIndex InstalledPackage+                     -> PackageIndex                      -> InstallPlan                      -> IO InstallPlan performInstallations verbosity   (packageDBs, _, comp, conf,-   globalFlags, configFlags, configExFlags, installFlags)-  installed installPlan = do+   globalFlags, configFlags, configExFlags, installFlags, haddockFlags)+  installedPkgIndex installPlan = do    executeInstallPlan installPlan $ \cpkg ->     installConfiguredPackage platform compid configFlags                              cpkg $ \configFlags' src pkg ->-      fetchAvailablePackage verbosity src $ \src' ->+      fetchSourcePackage verbosity src $ \src' ->         installLocalPackage verbosity (packageId pkg) src' $ \mpath ->-          installUnpackedPackage verbosity (setupScriptOptions installed)-                                 miscOptions configFlags' installFlags+          installUnpackedPackage verbosity+                                 (setupScriptOptions installedPkgIndex)+                                 miscOptions configFlags' installFlags haddockFlags                                  compid pkg mpath useLogFile    where@@ -646,7 +819,7 @@         -- which kind of means it was not their fault.  --- | Call an installer for an 'AvailablePackage' but override the configure+-- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the -- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly -- versioned package dependencies. So we ignore any previous partial flag@@ -658,24 +831,26 @@                                          -> PackageDescription -> a)                          -> a installConfiguredPackage platform comp configFlags-  (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)+  (ConfiguredPackage (SourcePackage _ gpkg source) flags stanzas deps)   installPkg = installPkg configFlags {     configConfigurationsFlags = flags,-    configConstraints = map thisPackageVersion deps+    configConstraints = map thisPackageVersion deps,+    configBenchmarks = toFlag False,+    configTests = toFlag (TestStanzas `elem` stanzas)   } source pkg   where     pkg = case finalizePackageDescription flags            (const True)-           platform comp [] gpkg of+           platform comp [] (enableStanzas stanzas gpkg) of       Left _ -> error "finalizePackageDescription ConfiguredPackage failed"       Right (desc, _) -> desc -fetchAvailablePackage+fetchSourcePackage   :: Verbosity   -> PackageLocation (Maybe FilePath)   -> (PackageLocation FilePath -> IO BuildResult)   -> IO BuildResult-fetchAvailablePackage verbosity src installPkg = do+fetchSourcePackage verbosity src installPkg = do   fetched <- checkFetched src   case fetched of     Just src' -> installPkg src'@@ -728,13 +903,14 @@                    -> InstallMisc                    -> ConfigFlags                    -> InstallFlags+                   -> HaddockFlags                    -> CompilerId                    -> PackageDescription                    -> Maybe FilePath -- ^ Directory to change to before starting the installation.                    -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)                    -> IO BuildResult installUnpackedPackage verbosity scriptOptions miscOptions-                       configFlags installConfigFlags+                       configFlags installConfigFlags haddockFlags                        compid pkg workingDir useLogFile =    -- Configure phase@@ -747,23 +923,28 @@    -- Doc generation phase       docsResult <- if shouldHaddock-        then (do setup haddockCommand haddockFlags+        then (do setup haddockCommand haddockFlags'                  return DocsOk)                `catchIO`   (\_ -> return DocsFailed)                `catchExit` (\_ -> return DocsFailed)         else return DocsNotTried    -- Tests phase-      testsResult <- return TestsNotTried  --TODO: add optional tests+      onFailure TestsFailed $ do+        when (testsEnabled && PackageDescription.hasTests pkg) $+            setup Cabal.testCommand testFlags -  -- Install phase-      onFailure InstallFailed $-        withWin32SelfUpgrade verbosity configFlags compid pkg $ do-          case rootCmd miscOptions of-            (Just cmd) -> reexec cmd-            Nothing    -> setup Cabal.installCommand installFlags-          return (Right (BuildOk docsResult testsResult))+        let testsResult | testsEnabled = TestsOk+                        | otherwise = TestsNotTried +      -- Install phase+        onFailure InstallFailed $+          withWin32SelfUpgrade verbosity configFlags compid pkg $ do+            case rootCmd miscOptions of+              (Just cmd) -> reexec cmd+              Nothing    -> setup Cabal.installCommand installFlags+            return (Right (BuildOk docsResult testsResult))+   where     configureFlags   = filterConfigureFlags configFlags {       configVerbosity = toFlag verbosity'@@ -774,10 +955,11 @@       buildVerbosity = toFlag verbosity'     }     shouldHaddock    = fromFlag (installDocumentation installConfigFlags)-    haddockFlags _   = emptyHaddockFlags {-      haddockDistPref  = configDistPref configFlags,+    haddockFlags' _   = haddockFlags {       haddockVerbosity = toFlag verbosity'     }+    testsEnabled = fromFlag (configTests configFlags)+    testFlags _ = Cabal.emptyTestFlags     installFlags _   = Cabal.emptyInstallFlags {       Cabal.installDistPref  = configDistPref configFlags,       Cabal.installVerbosity = toFlag verbosity'

Distribution/Client/InstallPlan.hs view

@@ -45,9 +45,8 @@   ) where  import Distribution.Client.Types-         ( AvailablePackage(packageDescription), ConfiguredPackage(..)-         , InstalledPackage-         , BuildFailure, BuildSuccess )+         ( SourcePackage(packageDescription), ConfiguredPackage(..)+         , InstalledPackage, BuildFailure, BuildSuccess, enableStanzas ) import Distribution.Package          ( PackageIdentifier(..), PackageName(..), Package(..), packageName          , PackageFixedDeps(..), Dependency(..) )@@ -88,32 +87,32 @@ -- -- The Problem: ----- In general we start with a set of installed packages and a set of available+-- In general we start with a set of installed packages and a set of source -- packages. -- -- Installed packages have fixed dependencies. They have already been built and -- we know exactly what packages they were built against, including their exact--- versions. +-- versions. ----- Available package have somewhat flexible dependencies. They are specified as+-- Source package have somewhat flexible dependencies. They are specified as -- version ranges, though really they're predicates. To make matters worse they -- have conditional flexible dependencies. Configuration flags can affect which -- packages are required and can place additional constraints on their -- versions. -- -- These two sets of package can and usually do overlap. There can be installed--- packages that are also available which means they could be re-installed if--- required, though there will also be packages which are not available and--- cannot be re-installed. Very often there will be extra versions available--- than are installed. Sometimes we may like to prefer installed packages over--- available ones or perhaps always prefer the latest available version whether--- installed or not.+-- packages that are also available as source packages which means they could+-- be re-installed if required, though there will also be packages which are+-- not available as source and cannot be re-installed. Very often there will be+-- extra versions available than are installed. Sometimes we may like to prefer+-- installed packages over source ones or perhaps always prefer the latest+-- available version whether installed or not. -- -- The goal is to calculate an installation plan that is closed, acyclic and -- consistent and where every configured package is valid. -- -- An installation plan is a set of packages that are going to be used--- together. It will consist of a mixture of installed packages and available+-- together. It will consist of a mixture of installed packages and source -- packages along with their exact version dependencies. An installation plan -- is closed if for every package in the set, all of its dependencies are -- also in the set. It is consistent if for every package in the set, all@@ -472,7 +471,7 @@ configuredPackageProblems :: Platform -> CompilerId                           -> ConfiguredPackage -> [PackageProblem] configuredPackageProblems platform comp-  (ConfiguredPackage pkg specifiedFlags specifiedDeps) =+  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps) =      [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]   ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]@@ -506,6 +505,6 @@          (const True)          platform comp          []-         (packageDescription pkg) of+         (enableStanzas stanzas $ packageDescription pkg) of         Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg         Left  _ -> error "configuredPackageInvalidDeps internal error"

Distribution/Client/InstallSymlink.hs view

@@ -40,7 +40,7 @@ #else  import Distribution.Client.Types-         ( AvailablePackage(..), ConfiguredPackage(..) )+         ( SourcePackage(..), ConfiguredPackage(..), enableStanzas ) import Distribution.Client.Setup          ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -132,10 +132,10 @@       , PackageDescription.buildable (PackageDescription.buildInfo exe) ]      pkgDescription :: ConfiguredPackage -> PackageDescription-    pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =+    pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags stanzas _) =       case finalizePackageDescription flags              (const True)-             platform compilerId [] pkg of+             platform compilerId [] (enableStanzas stanzas pkg) of         Left _ -> error "finalizePackageDescription ConfiguredPackage failed"         Right (desc, _) -> desc

Distribution/Client/List.hs view

@@ -15,11 +15,11 @@  import Distribution.Package          ( PackageName(..), Package(..), packageName, packageVersion-         , Dependency(..), thisPackageVersion, depends, simplifyDependency )+         , Dependency(..), simplifyDependency ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed-import qualified Distribution.PackageDescription   as Available+import qualified Distribution.PackageDescription   as Source import Distribution.PackageDescription          ( Flag(..), FlagName(..) ) import Distribution.PackageDescription.Configuration@@ -31,6 +31,7 @@ import Distribution.Simple.Utils         ( equating, comparing, die, notice ) import Distribution.Simple.Setup (fromFlag)+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version          ( Version(..), VersionRange, withinRange, anyVersion@@ -40,10 +41,9 @@          ( Text(disp), display )  import Distribution.Client.Types-         ( AvailablePackage(..), Repo, AvailablePackageDb(..)-         , InstalledPackage(..) )+         ( SourcePackage(..), Repo, SourcePackageDb(..) ) import Distribution.Client.Dependency.Types-         ( PackageConstraint(..) )+         ( PackageConstraint(..), ExtDependency(..) ) import Distribution.Client.Targets          ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup@@ -51,7 +51,7 @@ import Distribution.Client.Utils          ( mergeBy, MergeResult(..) ) import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, getInstalledPackages )+         ( getSourcePackages, getInstalledPackages ) import Distribution.Client.FetchUtils          ( isFetched ) @@ -65,7 +65,7 @@          ( MonadPlus(mplus), join ) import Control.Exception          ( assert )-import Text.PrettyPrint.HughesPJ as Disp+import Text.PrettyPrint as Disp import System.Directory          ( doesDirectoryExist ) @@ -81,29 +81,29 @@      -> IO () list verbosity packageDBs repos comp conf listFlags pats = do -    installed   <- getInstalledPackages verbosity comp packageDBs conf-    availableDb <- getAvailablePackages verbosity repos-    let available  = packageIndex availableDb+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos+    let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion-                       (Map.lookup name (packagePreferences availableDb))+                       (Map.lookup name (packagePreferences sourcePkgDb)) -        pkgsInfo :: [(PackageName, [InstalledPackage], [AvailablePackage])]+        pkgsInfo :: [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]         pkgsInfo             -- gather info for all packages-          | null pats = mergePackages (PackageIndex.allPackages installed)-                                      (PackageIndex.allPackages available)+          | null pats = mergePackages (InstalledPackageIndex.allPackages installedPkgIndex)+                                      (         PackageIndex.allPackages sourcePkgIndex)              -- gather info for packages matching search term-          | otherwise = mergePackages (matchingPackages installed)-                                      (matchingPackages available)+          | otherwise = mergePackages (matchingPackages InstalledPackageIndex.searchByNameSubstring installedPkgIndex)+                                      (matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchByNameSubstring idx n)) sourcePkgIndex)          matches :: [PackageDisplayInfo]         matches = [ mergePackageInfo pref-                      installedPkgs availablePkgs selectedPkg False-                  | (pkgname, installedPkgs, availablePkgs) <- pkgsInfo+                      installedPkgs sourcePkgs selectedPkg False+                  | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo                   , not onlyInstalled || not (null installedPkgs)                   , let pref        = prefs pkgname-                        selectedPkg = latestWithPref pref availablePkgs ]+                        selectedPkg = latestWithPref pref sourcePkgs ]      if simpleOutput       then putStr $ unlines@@ -112,10 +112,10 @@              , version <- if onlyInstalled                             then              installedVersions pkg                             else nub . sort $ installedVersions pkg-                                           ++ availableVersions pkg ]+                                           ++ sourceVersions    pkg ]              -- Note: this only works because for 'list', one cannot currently              -- specify any version constraints, so listing all installed-             -- and available ones works.+             -- and source ones works.       else         if null matches             then notice verbosity "No matches found."@@ -124,11 +124,10 @@     onlyInstalled = fromFlag (listInstalled listFlags)     simpleOutput  = fromFlag (listSimpleOutput listFlags) -    matchingPackages index =+    matchingPackages search index =       [ pkg       | pat <- pats-      , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat-      , pkg <- pkgs ]+      , pkg <- search index pat ]  info :: Verbosity      -> PackageDBStack@@ -142,66 +141,73 @@ info verbosity packageDBs repos comp conf      globalFlags _listFlags userTargets = do -    installed     <- getInstalledPackages verbosity comp packageDBs conf-    availableDb   <- getAvailablePackages verbosity repos-    let available  = packageIndex availableDb+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb   <- getSourcePackages    verbosity repos+    let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion-                       (Map.lookup name (packagePreferences availableDb))+                       (Map.lookup name (packagePreferences sourcePkgDb))          -- Users may specify names of packages that are only installed, not         -- just available source packages, so we must resolve targets using-        -- the combination of installed and available packages.-    let available' = PackageIndex.fromList-                   $ map packageId (PackageIndex.allPackages installed)-                  ++ map packageId (PackageIndex.allPackages available)+        -- the combination of installed and source packages.+    let sourcePkgs' = PackageIndex.fromList+                    $ map packageId (InstalledPackageIndex.allPackages installedPkgIndex)+                   ++ map packageId (         PackageIndex.allPackages sourcePkgIndex)     pkgSpecifiers <- resolveUserTargets verbosity-                       globalFlags available' userTargets+                       (fromFlag $ globalWorldFile globalFlags)+                       sourcePkgs' userTargets      pkgsinfo      <- sequence                        [ do pkginfo <- either die return $                                          gatherPkgInfo prefs-                                           installed available pkgSpecifier+                                           installedPkgIndex sourcePkgIndex+                                           pkgSpecifier                             updateFileSystemPackageDetails pkginfo                        | pkgSpecifier <- pkgSpecifiers ]      putStr $ unlines (map showPackageDetailedInfo pkgsinfo)    where-    gatherPkgInfo prefs installed available (NamedPackage name constraints)-      | null (selectedInstalledPkgs) && null (selectedAvailablePkgs)+    gatherPkgInfo :: (PackageName -> VersionRange) ->+                     InstalledPackageIndex.PackageIndex ->+                     PackageIndex.PackageIndex SourcePackage ->+                     PackageSpecifier SourcePackage ->+                     Either String PackageDisplayInfo+    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints)+      | null (selectedInstalledPkgs) && null (selectedSourcePkgs)       = Left $ "There is no available version of " ++ display name             ++ " that satisfies "             ++ display (simplifyVersionRange verConstraint)        | otherwise       = Right $ mergePackageInfo pref installedPkgs-                                 availablePkgs  selectedAvailablePkg+                                 sourcePkgs  selectedSourcePkg'                                  showPkgVersion       where         pref           = prefs name-        installedPkgs  = PackageIndex.lookupPackageName installed name-        availablePkgs  = PackageIndex.lookupPackageName available name+        installedPkgs  = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)+        sourcePkgs     =                         PackageIndex.lookupPackageName sourcePkgIndex name -        selectedInstalledPkgs = PackageIndex.lookupDependency installed+        selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex                                     (Dependency name verConstraint)-        selectedAvailablePkgs = PackageIndex.lookupDependency available+        selectedSourcePkgs    =          PackageIndex.lookupDependency sourcePkgIndex                                     (Dependency name verConstraint)-        selectedAvailablePkg  = latestWithPref pref selectedAvailablePkgs+        selectedSourcePkg'    = latestWithPref pref selectedSourcePkgs                           -- display a specific package version if the user                          -- supplied a non-trivial version constraint         showPkgVersion = not (null verConstraints)         verConstraint  = foldr intersectVersionRanges anyVersion verConstraints-        verConstraints = [ vr | PackageVersionConstraint _ vr <- constraints ]+        verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] -    gatherPkgInfo prefs installed available (SpecificSourcePackage pkg) =-        Right $ mergePackageInfo pref installedPkgs availablePkgs+    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) =+        Right $ mergePackageInfo pref installedPkgs sourcePkgs                                  selectedPkg True       where         name          = packageName pkg         pref          = prefs name-        installedPkgs = PackageIndex.lookupPackageName installed name-        availablePkgs = PackageIndex.lookupPackageName available name+        installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)+        sourcePkgs    =                         PackageIndex.lookupPackageName sourcePkgIndex name         selectedPkg   = Just pkg  @@ -211,9 +217,9 @@ data PackageDisplayInfo = PackageDisplayInfo {     pkgName           :: PackageName,     selectedVersion   :: Maybe Version,-    selectedAvailable :: Maybe AvailablePackage,+    selectedSourcePkg :: Maybe SourcePackage,     installedVersions :: [Version],-    availableVersions :: [Version],+    sourceVersions    :: [Version],     preferredVersions :: VersionRange,     homepage          :: String,     bugReports        :: String,@@ -224,7 +230,7 @@     license           :: License,     author            :: String,     maintainer        :: String,-    dependencies      :: [Dependency],+    dependencies      :: [ExtDependency],     flags             :: [Flag],     hasLib            :: Bool,     hasExe            :: Bool,@@ -242,7 +248,7 @@      (nest 4 $ vcat [        maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs      , text "Default available version:" <+>-       case selectedAvailable pkginfo of+       case selectedSourcePkg pkginfo of          Nothing  -> text "[ Not available from any configured repository ]"          Just pkg -> disp (packageVersion pkg)      , text "Installed versions:" <+>@@ -269,7 +275,7 @@    $+$    (nest 4 $ vcat [      entry "Synopsis"      synopsis     hideIfNull     reflowParagraphs-   , entry "Versions available" availableVersions+   , entry "Versions available" sourceVersions            (altText null "[ Not available from server ]")            (dispTopVersions 9 (preferredVersions pkginfo))    , entry "Versions installed" installedVersions@@ -351,56 +357,55 @@ -- package name. -- mergePackageInfo :: VersionRange-                 -> [InstalledPackage]-                 -> [AvailablePackage]-                 -> Maybe AvailablePackage+                 -> [Installed.InstalledPackageInfo]+                 -> [SourcePackage]+                 -> Maybe SourcePackage                  -> Bool                  -> PackageDisplayInfo-mergePackageInfo versionPref installedPkgs availablePkgs selectedPkg showVer =-  assert (length installedPkgs + length availablePkgs > 0) $+mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =+  assert (length installedPkgs + length sourcePkgs > 0) $   PackageDisplayInfo {-    pkgName           = combine packageName available+    pkgName           = combine packageName source                                 packageName installed,     selectedVersion   = if showVer then fmap packageVersion selectedPkg                                    else Nothing,-    selectedAvailable = availableSelected,+    selectedSourcePkg = sourceSelected,     installedVersions = map packageVersion installedPkgs,-    availableVersions = map packageVersion availablePkgs,+    sourceVersions    = map packageVersion sourcePkgs,     preferredVersions = versionPref, -    license      = combine Available.license    available+    license      = combine Source.license       source                            Installed.license    installed,-    maintainer   = combine Available.maintainer available+    maintainer   = combine Source.maintainer    source                            Installed.maintainer installed,-    author       = combine Available.author     available+    author       = combine Source.author        source                            Installed.author     installed,-    homepage     = combine Available.homepage   available+    homepage     = combine Source.homepage      source                            Installed.homepage   installed,-    bugReports   = maybe "" Available.bugReports available,+    bugReports   = maybe "" Source.bugReports source,     sourceRepo   = fromMaybe "" . join-                 . fmap (uncons Nothing Available.repoLocation-                       . sortBy (comparing Available.repoKind)-                       . Available.sourceRepos)-                 $ available,+                 . fmap (uncons Nothing Source.repoLocation+                       . sortBy (comparing Source.repoKind)+                       . Source.sourceRepos)+                 $ source,                     --TODO: installed package info is missing synopsis-    synopsis     = maybe "" Available.synopsis   available,-    description  = combine Available.description available+    synopsis     = maybe "" Source.synopsis      source,+    description  = combine Source.description    source                            Installed.description installed,-    category     = combine Available.category    available+    category     = combine Source.category       source                            Installed.category    installed,-    flags        = maybe [] Available.genPackageFlags availableGeneric,+    flags        = maybe [] Source.genPackageFlags sourceGeneric,     hasLib       = isJust installed                 || fromMaybe False-                   (fmap (isJust . Available.condLibrary) availableGeneric),+                   (fmap (isJust . Source.condLibrary) sourceGeneric),     hasExe       = fromMaybe False-                   (fmap (not . null . Available.condExecutables) availableGeneric),-    executables  = map fst (maybe [] Available.condExecutables availableGeneric),+                   (fmap (not . null . Source.condExecutables) sourceGeneric),+    executables  = map fst (maybe [] Source.condExecutables sourceGeneric),     modules      = combine Installed.exposedModules installed-                           (maybe [] Available.exposedModules-                                   . Available.library) available,-    dependencies = map simplifyDependency-                 $ combine Available.buildDepends available-                           (map thisPackageVersion . depends) installed',+                           (maybe [] Source.exposedModules+                                   . Source.library) source,+    dependencies = combine (map (SourceDependency . simplifyDependency) . Source.buildDepends) source+                           (map InstalledDependency . Installed.depends) installed,     haddockHtml  = fromMaybe "" . join                  . fmap (listToMaybe . Installed.haddockHTMLs)                  $ installed,@@ -408,14 +413,14 @@   }   where     combine f x g y  = fromJust (fmap f x `mplus` fmap g y)-    installed'       = latestWithPref versionPref installedPkgs-    installed        = fmap (\(InstalledPackage p _) -> p) installed'+    installed :: Maybe Installed.InstalledPackageInfo+    installed = latestWithPref versionPref installedPkgs -    availableSelected+    sourceSelected       | isJust selectedPkg = selectedPkg-      | otherwise          = latestWithPref versionPref availablePkgs-    availableGeneric = fmap packageDescription availableSelected-    available        = fmap flattenPackageDescription availableGeneric+      | otherwise          = latestWithPref versionPref sourcePkgs+    sourceGeneric = fmap packageDescription sourceSelected+    source        = fmap flattenPackageDescription sourceGeneric      uncons :: b -> (a -> b) -> [a] -> b     uncons z _ []    = z@@ -429,7 +434,7 @@ updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo updateFileSystemPackageDetails pkginfo = do   fetched   <- maybe (return False) (isFetched . packageSource)-                     (selectedAvailable pkginfo)+                     (selectedSourcePkg pkginfo)   docsExist <- doesDirectoryExist (haddockHtml pkginfo)   return pkginfo {     haveTarball = fetched,@@ -444,20 +449,20 @@                            in (withinRange ver pref, ver)  --- | Rearrange installed and available packages into groups referring to the+-- | Rearrange installed and source packages into groups referring to the -- same package by name. In the result pairs, the lists are guaranteed to not -- both be empty. ---mergePackages :: [InstalledPackage]-              -> [AvailablePackage]+mergePackages :: [Installed.InstalledPackageInfo]+              -> [SourcePackage]               -> [( PackageName-                  , [InstalledPackage]-                  , [AvailablePackage] )]-mergePackages installed available =+                  , [Installed.InstalledPackageInfo]+                  , [SourcePackage] )]+mergePackages installedPkgs sourcePkgs =     map collect   $ mergeBy (\i a -> fst i `compare` fst a)-            (groupOn packageName installed)-            (groupOn packageName available)+            (groupOn packageName installedPkgs)+            (groupOn packageName sourcePkgs)   where     collect (OnlyInLeft  (name,is)         ) = (name, is, [])     collect (    InBoth  (_,is)   (name,as)) = (name, is, as)

Distribution/Client/PackageIndex.hs view

@@ -27,6 +27,8 @@   -- * Queries    -- ** Precise lookups+  elemByPackageId,+  elemByPackageName,   lookupPackageName,   lookupPackageId,   lookupDependency,@@ -61,7 +63,7 @@ import Data.Array ((!)) import Data.List (groupBy, sortBy, nub, isInfixOf) import Data.Monoid (Monoid(..))-import Data.Maybe (isNothing, fromMaybe)+import Data.Maybe (isJust, isNothing, fromMaybe)  import Distribution.Package          ( PackageName(..), PackageIdentifier(..)@@ -76,7 +78,7 @@ -- -- It can be searched effeciently by package name and version. ---newtype Package pkg => PackageIndex pkg = PackageIndex+newtype PackageIndex pkg = PackageIndex   -- This index package names to all the package records matching that package   -- name case-sensitively. It includes all versions.   --@@ -235,6 +237,13 @@ -- -- * Lookups --++elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool+elemByPackageId index = isJust . lookupPackageId index++elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool+elemByPackageName index = not . null . lookupPackageName index+  -- | Does a lookup by package id (name & version). --

Distribution/Client/Setup.hs view

@@ -26,6 +26,7 @@     , reportCommand, ReportFlags(..)     , unpackCommand, UnpackFlags(..)     , initCommand, IT.InitFlags(..)+    , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)      , parsePackageArgs     --TODO: stop exporting these:@@ -37,20 +38,23 @@          ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) )+import Distribution.Client.Dependency.Types+         ( PreSolver(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) )+import Distribution.Client.Targets+         ( UserConstraint, readUserConstraint )  import Distribution.Simple.Program          ( defaultProgramConfiguration ) import Distribution.Simple.Command hiding (boolOpt)-import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal-         ( configureCommand )+         ( configureCommand, sdistCommand, haddockCommand ) import Distribution.Simple.Setup-         ( ConfigFlags(..) )+         ( ConfigFlags(..), SDistFlags(..), HaddockFlags(..) ) import Distribution.Simple.Setup-         ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe-         , optionVerbosity, trueArg, falseArg )+         ( Flag(..), toFlag, fromFlag, flagToMaybe, flagToList+         , optionVerbosity, boolOpt, trueArg, falseArg ) import Distribution.Simple.InstallDirs          ( PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Version@@ -60,9 +64,9 @@ import Distribution.Text          ( Text(parse), display ) import Distribution.ReadE-         ( readP_to_E, succeedReadE )+         ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, readP_to_S, char, munch1, pfail, (+++) )+         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, (+++) ) import Distribution.Verbosity          ( Verbosity, normal ) import Distribution.Simple.Utils@@ -70,6 +74,8 @@  import Data.Char          ( isSpace, isAlphaNum )+import Data.List+         ( intercalate ) import Data.Maybe          ( listToMaybe, maybeToList, fromMaybe ) import Data.Monoid@@ -90,7 +96,7 @@     globalVersion        :: Flag Bool,     globalNumericVersion :: Flag Bool,     globalConfigFile     :: Flag FilePath,-    globalRemoteRepos    :: [RemoteRepo],     -- ^Available Hackage servers.+    globalRemoteRepos    :: [RemoteRepo],     -- ^ Available Hackage servers.     globalCacheDir       :: Flag FilePath,     globalLocalRepos     :: [FilePath],     globalLogsDir        :: Flag FilePath,@@ -222,7 +228,6 @@     -- older Cabal does not grok the constraints flag:   | otherwise = flags { configConstraints = [] } - -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------@@ -231,17 +236,20 @@ -- data ConfigExFlags = ConfigExFlags {     configCabalVersion :: Flag Version,-    configPreferences  :: [Dependency]+    configExConstraints:: [UserConstraint],+    configPreferences  :: [Dependency],+    configSolver       :: Flag PreSolver   }  defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty+defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }  configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand {     commandDefaultFlags = (mempty, defaultConfigExFlags),     commandOptions      = \showOrParseArgs ->-         liftOptions fst setFst (configureOptions   showOrParseArgs)+         liftOptions fst setFst (filter ((/="constraint") . optionName) $+                                 configureOptions   showOrParseArgs)       ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)   }   where@@ -257,23 +265,36 @@       (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)                                     (fmap toFlag parse))                         (map display . flagToList))+  , option [] ["constraint"]+      "Specify constraints on a package (version, installed/source, flags)"+      configExConstraints (\v flags -> flags { configExConstraints = v })+      (reqArg "CONSTRAINT"+              (fmap (\x -> [x]) (ReadE readUserConstraint))+              (map display))    , option [] ["preference"]       "Specify preferences (soft constraints) on the version of a package"       configPreferences (\v flags -> flags { configPreferences = v })-      (reqArg "DEPENDENCY"-        (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))-                                        (map (\x -> display x)))+      (reqArg "CONSTRAINT"+              (readP_to_E (const "dependency expected")+                          (fmap (\x -> [x]) parse))+              (map display))++  , optionSolver configSolver (\v flags -> flags { configSolver = v })   ]  instance Monoid ConfigExFlags where   mempty = ConfigExFlags {     configCabalVersion = mempty,-    configPreferences  = mempty+    configExConstraints= mempty,+    configPreferences  = mempty,+    configSolver       = mempty   }   mappend a b = ConfigExFlags {     configCabalVersion = combine configCabalVersion,-    configPreferences  = combine configPreferences+    configExConstraints= combine configExConstraints,+    configPreferences  = combine configPreferences,+    configSolver       = combine configSolver   }     where combine field = field a `mappend` field b @@ -285,6 +306,11 @@ --    fetchOutput    :: Flag FilePath,       fetchDeps      :: Flag Bool,       fetchDryRun    :: Flag Bool,+      fetchSolver           :: Flag PreSolver,+      fetchMaxBackjumps     :: Flag Int,+      fetchReorderGoals     :: Flag Bool,+      fetchIndependentGoals :: Flag Bool,+      fetchShadowPkgs       :: Flag Bool,       fetchVerbosity :: Flag Verbosity     } @@ -293,6 +319,11 @@ --  fetchOutput    = mempty,     fetchDeps      = toFlag True,     fetchDryRun    = toFlag False,+    fetchSolver           = Flag defaultSolver,+    fetchMaxBackjumps     = Flag defaultMaxBackjumps,+    fetchReorderGoals     = Flag False,+    fetchIndependentGoals = Flag False,+    fetchShadowPkgs       = Flag False,     fetchVerbosity = toFlag normal    } @@ -303,7 +334,7 @@     commandDescription  = Nothing,     commandUsage        = usagePackages "fetch",     commandDefaultFlags = defaultFetchFlags,-    commandOptions      = \_ -> [+    commandOptions      = \ showOrParseArgs -> [          optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })  --     , option "o" ["output"]@@ -325,7 +356,16 @@            "Do not install anything, only print what would be installed."            fetchDryRun (\v flags -> flags { fetchDryRun = v })            trueArg-       ]++       ] ++++       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :+       optionSolverFlags showOrParseArgs+                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })+                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })+                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })+                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })+   }  -- ------------------------------------------------------------@@ -342,13 +382,13 @@     commandOptions      = \_ -> [optionVerbosity id const]   } -upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) upgradeCommand = configureCommand {     commandName         = "upgrade",     commandSynopsis     = "(command disabled, use install instead)",     commandDescription  = Nothing,     commandUsage        = usagePackages "upgrade",-    commandDefaultFlags = (mempty, mempty, mempty),+    commandDefaultFlags = (mempty, mempty, mempty, mempty),     commandOptions      = commandOptions installCommand   } @@ -557,41 +597,62 @@ -- | Install takes the same flags as configure along with a few extras. -- data InstallFlags = InstallFlags {-    installDocumentation:: Flag Bool,-    installHaddockIndex :: Flag PathTemplate,-    installDryRun       :: Flag Bool,-    installReinstall    :: Flag Bool,-    installUpgradeDeps  :: Flag Bool,-    installOnly         :: Flag Bool,-    installOnlyDeps     :: Flag Bool,-    installRootCmd      :: Flag String,-    installSummaryFile  :: [PathTemplate],-    installLogFile      :: Flag PathTemplate,-    installBuildReports :: Flag ReportLevel,-    installSymlinkBinDir:: Flag FilePath,-    installOneShot      :: Flag Bool+    installDocumentation    :: Flag Bool,+    installHaddockIndex     :: Flag PathTemplate,+    installDryRun           :: Flag Bool,+    installMaxBackjumps     :: Flag Int,+    installReorderGoals     :: Flag Bool,+    installIndependentGoals :: Flag Bool,+    installShadowPkgs       :: Flag Bool,+    installReinstall        :: Flag Bool,+    installAvoidReinstalls  :: Flag Bool,+    installOverrideReinstall :: Flag Bool,+    installUpgradeDeps      :: Flag Bool,+    installOnly             :: Flag Bool,+    installOnlyDeps         :: Flag Bool,+    installRootCmd          :: Flag String,+    installSummaryFile      :: [PathTemplate],+    installLogFile          :: Flag PathTemplate,+    installBuildReports     :: Flag ReportLevel,+    installSymlinkBinDir    :: Flag FilePath,+    installOneShot          :: Flag Bool   }  defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags {-    installDocumentation= Flag False,-    installHaddockIndex = Flag docIndexFile,-    installDryRun       = Flag False,-    installReinstall    = Flag False,-    installUpgradeDeps  = Flag False,-    installOnly         = Flag False,-    installOnlyDeps     = Flag False,-    installRootCmd      = mempty,-    installSummaryFile  = mempty,-    installLogFile      = mempty,-    installBuildReports = Flag NoReports,-    installSymlinkBinDir= mempty,-    installOneShot      = Flag False+    installDocumentation   = Flag False,+    installHaddockIndex    = Flag docIndexFile,+    installDryRun          = Flag False,+    installMaxBackjumps    = Flag defaultMaxBackjumps,+    installReorderGoals    = Flag False,+    installIndependentGoals= Flag False,+    installShadowPkgs      = Flag False,+    installReinstall       = Flag False,+    installAvoidReinstalls = Flag False,+    installOverrideReinstall = Flag False,+    installUpgradeDeps     = Flag False,+    installOnly            = Flag False,+    installOnlyDeps        = Flag False,+    installRootCmd         = mempty,+    installSummaryFile     = mempty,+    installLogFile         = mempty,+    installBuildReports    = Flag NoReports,+    installSymlinkBinDir   = mempty,+    installOneShot         = Flag False   }   where     docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html") -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+defaultMaxBackjumps :: Int+defaultMaxBackjumps = 200++defaultSolver :: PreSolver+defaultSolver = Choose++allSolvers :: String+allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver]))++installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) installCommand = CommandUI {   commandName         = "install",   commandSynopsis     = "Installs a list of packages.",@@ -610,17 +671,38 @@      ++ "    Specific version of a package\n"      ++ "  " ++ pname ++ " install 'foo < 2'       "      ++ "    Constrained package version\n",-  commandDefaultFlags = (mempty, mempty, mempty),+  commandDefaultFlags = (mempty, mempty, mempty, mempty),   commandOptions      = \showOrParseArgs ->-       liftOptions get1 set1 (configureOptions   showOrParseArgs)+       liftOptions get1 set1 (filter ((/="constraint") . optionName) $+                              configureOptions   showOrParseArgs)     ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)     ++ liftOptions get3 set3 (installOptions     showOrParseArgs)+    ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)   }   where-    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)-    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)-    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)+    get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d)+    get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d)+    get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)+    get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) +    haddockOptions showOrParseArgs+      = [ opt { optionName = "haddock-" ++ name,+                optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr+                              | descr <- optionDescr opt] }+        | opt <- commandOptions Cabal.haddockCommand showOrParseArgs+        , let name = optionName opt+        , name `elem` ["hoogle", "html", "html-location",+                       "executables", "internal", "css",+                       "hyperlink-source", "hscolour-css",+                       "contents-location"]+        ]++    fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a+    fmapOptFlags modify (ReqArg d f p r w)    = ReqArg d (modify f) p r w+    fmapOptFlags modify (OptArg d f p r i w)  = OptArg d (modify f) p r i w+    fmapOptFlags modify (ChoiceOpt xs)        = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]+    fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w+ installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags] installOptions showOrParseArgs =       [ option "" ["documentation"]@@ -638,23 +720,38 @@           "Do not install anything, only print what would be installed."           installDryRun (\v flags -> flags { installDryRun = v })           trueArg+      ] ++ -      , option [] ["reinstall"]+      optionSolverFlags showOrParseArgs+                        installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })+                        installReorderGoals     (\v flags -> flags { installReorderGoals     = v })+                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v })+                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) ++++      [ option [] ["reinstall"]           "Install even if it means installing the same version again."           installReinstall (\v flags -> flags { installReinstall = v })-          trueArg+          (yesNoOpt showOrParseArgs) +      , option [] ["avoid-reinstalls"]+          "Do not select versions that would destructively overwrite installed packages."+          installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v })+          (yesNoOpt showOrParseArgs)++      , option [] ["force-reinstalls"]+          "Reinstall packages even if they will most likely break other installed packages."+          installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })+          (yesNoOpt showOrParseArgs)+       , option [] ["upgrade-dependencies"]           "Pick the latest version for all dependencies, rather than trying to pick an installed version."           installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })-          trueArg-+          (yesNoOpt showOrParseArgs)        , option [] ["only-dependencies"]           "Install only the dependencies necessary to build the given packages"           installOnlyDeps (\v flags -> flags { installOnlyDeps = v })-          trueArg-+          (yesNoOpt showOrParseArgs)        , option [] ["root-cmd"]           "Command used to gain root privileges, when installing with --global."@@ -688,7 +785,7 @@       , option [] ["one-shot"]           "Do not record the packages in the world file."           installOneShot (\v flags -> flags { installOneShot = v })-          trueArg+          (yesNoOpt showOrParseArgs)       ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids           ParseArgs ->             option [] ["only"]@@ -700,34 +797,46 @@  instance Monoid InstallFlags where   mempty = InstallFlags {-    installDocumentation= mempty,-    installHaddockIndex = mempty,-    installDryRun       = mempty,-    installReinstall    = mempty,-    installUpgradeDeps  = mempty,-    installOnly         = mempty,-    installOnlyDeps     = mempty,-    installRootCmd      = mempty,-    installSummaryFile  = mempty,-    installLogFile      = mempty,-    installBuildReports = mempty,-    installSymlinkBinDir= mempty,-    installOneShot      = mempty+    installDocumentation   = mempty,+    installHaddockIndex    = mempty,+    installDryRun          = mempty,+    installReinstall       = mempty,+    installAvoidReinstalls = mempty,+    installOverrideReinstall = mempty,+    installMaxBackjumps    = mempty,+    installUpgradeDeps     = mempty,+    installReorderGoals    = mempty,+    installIndependentGoals= mempty,+    installShadowPkgs      = mempty,+    installOnly            = mempty,+    installOnlyDeps        = mempty,+    installRootCmd         = mempty,+    installSummaryFile     = mempty,+    installLogFile         = mempty,+    installBuildReports    = mempty,+    installSymlinkBinDir   = mempty,+    installOneShot         = mempty   }   mappend a b = InstallFlags {-    installDocumentation= combine installDocumentation,-    installHaddockIndex = combine installHaddockIndex,-    installDryRun       = combine installDryRun,-    installReinstall    = combine installReinstall,-    installUpgradeDeps  = combine installUpgradeDeps,-    installOnly         = combine installOnly,-    installOnlyDeps     = combine installOnlyDeps,-    installRootCmd      = combine installRootCmd,-    installSummaryFile  = combine installSummaryFile,-    installLogFile      = combine installLogFile,-    installBuildReports = combine installBuildReports,-    installSymlinkBinDir= combine installSymlinkBinDir,-    installOneShot      = combine installOneShot+    installDocumentation   = combine installDocumentation,+    installHaddockIndex    = combine installHaddockIndex,+    installDryRun          = combine installDryRun,+    installReinstall       = combine installReinstall,+    installAvoidReinstalls = combine installAvoidReinstalls,+    installOverrideReinstall = combine installOverrideReinstall,+    installMaxBackjumps    = combine installMaxBackjumps,+    installUpgradeDeps     = combine installUpgradeDeps,+    installReorderGoals    = combine installReorderGoals,+    installIndependentGoals= combine installIndependentGoals,+    installShadowPkgs      = combine installShadowPkgs,+    installOnly            = combine installOnly,+    installOnlyDeps        = combine installOnlyDeps,+    installRootCmd         = combine installRootCmd,+    installSummaryFile     = combine installSummaryFile,+    installLogFile         = combine installLogFile,+    installBuildReports    = combine installBuildReports,+    installSymlinkBinDir   = combine installSymlinkBinDir,+    installOneShot         = combine installOneShot   }     where combine field = field a `mappend` field b @@ -805,7 +914,7 @@ emptyInitFlags  = mempty  defaultInitFlags :: IT.InitFlags-defaultInitFlags  = emptyInitFlags+defaultInitFlags  = emptyInitFlags { IT.initVerbosity = toFlag normal }  initCommand :: CommandUI IT.InitFlags initCommand = CommandUI {@@ -939,6 +1048,8 @@         IT.buildTools (\v flags -> flags { IT.buildTools = v })         (reqArg' "TOOL" (Just . (:[]))                         (fromMaybe []))++      , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })       ]   }   where readMaybe s = case reads s of@@ -946,19 +1057,113 @@                         _         -> Nothing  -- --------------------------------------------------------------- * GetOpt Utils+-- * SDist flags -- ------------------------------------------------------------ -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-boolOpt  = Command.boolOpt  flagToMaybe Flag+-- | Extra flags to @sdist@ beyond runghc Setup sdist+--+data SDistExFlags = SDistExFlags {+    sDistFormat    :: Flag ArchiveFormat+  }+  deriving Show -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->-              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b+data ArchiveFormat = TargzFormat | ZipFormat -- | ...+  deriving (Show, Eq)++defaultSDistExFlags :: SDistExFlags+defaultSDistExFlags = SDistExFlags {+    sDistFormat  = Flag TargzFormat+  }++sdistCommand :: CommandUI (SDistFlags, SDistExFlags)+sdistCommand = Cabal.sdistCommand {+    commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand, defaultSDistExFlags),+    commandOptions      = \showOrParseArgs ->+         liftOptions fst setFst (commandOptions Cabal.sdistCommand showOrParseArgs)+      ++ liftOptions snd setSnd sdistExOptions+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++    sdistExOptions =+      [option [] ["archive-format"] "archive-format"+         sDistFormat (\v flags -> flags { sDistFormat = v })+         (choiceOpt+            [ (Flag TargzFormat, ([], ["targz"]),+                 "Produce a '.tar.gz' format archive (default and required for uploading to hackage)")+            , (Flag ZipFormat,   ([], ["zip"]),+                 "Produce a '.zip' format archive")+            ])+      ]++instance Monoid SDistExFlags where+  mempty = SDistExFlags {+    sDistFormat  = mempty+  }+  mappend a b = SDistExFlags {+    sDistFormat  = combine sDistFormat+  }+    where+      combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * GetOpt Utils+-- ------------------------------------------------------------++reqArgFlag :: ArgPlaceHolder ->+              MkOptDescr (b -> Flag String) (Flag String -> b -> b) b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList  liftOptions :: (b -> a) -> (a -> b -> b)             -> [OptionField a] -> [OptionField b] liftOptions get set = map (liftOption get set)++yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> (b -> b)) b+yesNoOpt ShowArgs sf lf = trueArg sf lf+yesNoOpt _        sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf++optionSolver :: (flags -> Flag PreSolver)+             -> (Flag PreSolver -> flags -> flags)+             -> OptionField flags+optionSolver get set =+  option [] ["solver"]+    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ", where 'choose' chooses between 'topdown' and 'modular' based on compiler version.")+    get set+    (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers)+                                 (toFlag `fmap` parse))+                     (flagToList . fmap display))++optionSolverFlags :: ShowOrParseArgs+                  -> (flags -> Flag Int   ) -> (Flag Int    -> flags -> flags)+                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)+                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)+                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)+                  -> [OptionField flags]+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip =+  [ option [] ["max-backjumps"]+      ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")+      getmbj setmbj+      (reqArg "NUM" (readP_to_E ("Cannot parse number: "++)+                                (fmap toFlag (Parse.readS_to_P reads)))+                    (map show . flagToList))+  , option [] ["reorder-goals"]+      "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."+      getrg setrg+      (yesNoOpt showOrParseArgs)+  -- TODO: Disabled for now because it does not work as advertised (yet).+{-+  , 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."+      getig setig+      (yesNoOpt showOrParseArgs)+-}+  , option [] ["shadow-installed-packages"]+      "If multiple package instances of the same version are installed, treat all but one as shadowed."+      getsip setsip+      trueArg+  ]+  usagePackages :: String -> String -> String usagePackages name pname =

Distribution/Client/SetupWrapper.hs view

@@ -34,7 +34,8 @@          , packageVersion, Dependency(..) ) import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)-         , PackageDescription(..), specVersion, BuildType(..) )+         , PackageDescription(..), specVersion+         , BuildType(..), knownBuildTypes ) import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Configure@@ -50,13 +51,13 @@          ( CommandUI(..), commandShowOptions ) import Distribution.Simple.GHC          ( ghcVerbosityOptions )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Client.IndexUtils          ( getInstalledPackages ) import Distribution.Simple.Utils          ( die, debug, info, cabalVersion, findPackageDesc, comparing-         , createDirectoryIfMissingVerbose, rewriteFile )+         , createDirectoryIfMissingVerbose, rewriteFile, intercalate ) import Distribution.Client.Utils          ( moreRecentFile, inDir ) import Distribution.Text@@ -78,7 +79,7 @@     useCabalVersion  :: VersionRange,     useCompiler      :: Maybe Compiler,     usePackageDB     :: PackageDBStack,-    usePackageIndex  :: Maybe (PackageIndex InstalledPackage),+    usePackageIndex  :: Maybe PackageIndex,     useProgramConfig :: ProgramConfiguration,     useDistPref      :: FilePath,     useLoggingHandle :: Maybe Handle,@@ -116,12 +117,18 @@       mkArgs cabalLibVersion = commandName cmd                              : commandShowOptions cmd (flags cabalLibVersion)                             ++ extraArgs+  checkBuildType buildType'   setupMethod verbosity options' (packageId pkg) buildType' mkArgs   where     getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options))          >>= readPackageDescription verbosity          >>= return . packageDescription +    checkBuildType (UnknownBuildType name) =+      die $ "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.@@ -215,7 +222,7 @@       []   -> die $ "The package requires Cabal library version "                  ++ display (useCabalVersion options)                  ++ " but no suitable version is installed."-      pkgs -> return $ bestVersion (map packageVersion pkgs)+      pkgs -> return $ bestVersion (map fst pkgs)     where       bestVersion          = maximumBy (comparing preference)       preference version   = (sameVersion, sameMajorVersion

Distribution/Client/SrcDist.hs view

@@ -4,42 +4,55 @@ module Distribution.Client.SrcDist (          sdist   )  where++ import Distribution.Simple.SrcDist-         ( printPackageProblems, prepareTree-         , prepareSnapshotTree, snapshotPackage )+         ( printPackageProblems, prepareTree, snapshotPackage ) import Distribution.Client.Tar (createTarGzFile)  import Distribution.Package-         ( Package(..) )+         ( Package(..), packageVersion ) import Distribution.PackageDescription          ( PackageDescription ) import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Utils-         ( defaultPackageDesc, warn, notice, setupMessage-         , createDirectoryIfMissingVerbose, withTempDirectory )-import Distribution.Simple.Setup (SDistFlags(..), fromFlag)+         ( defaultPackageDesc, die, warn, notice, setupMessage+         , createDirectoryIfMissingVerbose, withTempDirectory+         , withUTF8FileContents, writeUTF8File )+import Distribution.Client.Setup+         ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) )+import Distribution.Simple.Setup+         ( fromFlag, flagToMaybe ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PreProcess (knownSuffixHandlers) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Configure(maybeGetPersistBuildConfig) import Distribution.PackageDescription.Configuration ( flattenPackageDescription )+import Distribution.Simple.Program (requireProgram, simpleProgram, programPath)+import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text          ( display )+import Distribution.Version+         ( Version )  import System.Time (getClockTime, toCalendarTime) import System.FilePath ((</>), (<.>))-import Control.Monad (when)+import Control.Monad (when, unless) import Data.Maybe (isNothing)+import Data.Char (toLower)+import Data.List (isPrefixOf)+import System.Directory (doesFileExist, removeFile, canonicalizePath)+import System.Process (runProcess, waitForProcess)+import System.Exit    (ExitCode(..))  -- |Create a source distribution.-sdist :: SDistFlags -> IO ()-sdist flags = do+sdist :: SDistFlags -> SDistExFlags -> IO ()+sdist flags exflags = do   pkg <- return . flattenPackageDescription      =<< readPackageDescription verbosity      =<< defaultPackageDesc verbosity   mb_lbi <- maybeGetPersistBuildConfig distPref-  let tmpTargetDir = srcPref distPref    -- do some QA   printPackageProblems verbosity pkg@@ -47,34 +60,101 @@   when (isNothing mb_lbi) $     warn verbosity "Cannot run preprocessors. Run 'configure' command first." -  createDirectoryIfMissingVerbose verbosity True tmpTargetDir-  withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+  date <- toCalendarTime =<< getClockTime+  let pkg' | snapshot  = snapshotPackage date pkg+           | otherwise = pkg -    date <- toCalendarTime =<< getClockTime-    let pkg' | snapshot  = snapshotPackage date pkg-             | otherwise = pkg-    setupMessage verbosity "Building source dist for" (packageId pkg')+  case flagToMaybe (sDistDirectory flags) of+    Just targetDir -> do+      generateSourceDir targetDir pkg' mb_lbi+      notice verbosity $ "Source directory created: " ++ targetDir -    _ <- if snapshot-      then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps-      else prepareTree         verbosity pkg' mb_lbi distPref tmpDir pps-    targzFile <- createArchive verbosity pkg' tmpDir distPref-    notice verbosity $ "Source tarball created: " ++ targzFile+    Nothing -> do+      createDirectoryIfMissingVerbose verbosity True tmpTargetDir+      withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+        let targetDir = tmpDir </> tarBallName pkg'+        generateSourceDir targetDir pkg' mb_lbi+        targzFile <- createArchive verbosity format pkg' tmpDir targetPref+        notice verbosity $ "Source tarball created: " ++ targzFile    where+    generateSourceDir targetDir pkg' mb_lbi = do++      setupMessage verbosity "Building source dist for" (packageId pkg')+      prepareTree verbosity pkg' mb_lbi distPref targetDir pps+      when snapshot $+        overwriteSnapshotPackageDesc verbosity pkg' targetDir+     verbosity = fromFlag (sDistVerbosity flags)     snapshot  = fromFlag (sDistSnapshot flags)-    distPref  = fromFlag (sDistDistPref flags)+    format    = fromFlag (sDistFormat exflags)     pps       = knownSuffixHandlers+    distPref     = fromFlag $ sDistDistPref flags+    targetPref   = distPref+    tmpTargetDir = srcPref distPref --- |Create an archive from a tree of source files, and clean up the tree.+tarBallName :: PackageDescription -> String+tarBallName = display . packageId++overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity+                             -> PackageDescription -- ^info from the cabal file+                             -> FilePath           -- ^source tree+                             -> IO ()+overwriteSnapshotPackageDesc verbosity pkg targetDir = do+    -- We could just writePackageDescription targetDescFile pkg_descr,+    -- but that would lose comments and formatting.+    descFile <- defaultPackageDesc verbosity+    withUTF8FileContents descFile $+      writeUTF8File (targetDir </> descFile)+        . unlines . map (replaceVersion (packageVersion pkg)) . lines++  where+    replaceVersion :: Version -> String -> String+    replaceVersion version line+      | "version:" `isPrefixOf` map toLower line+                  = "version: " ++ display version+      | otherwise = line++-- | Create an archive from a tree of source files.+-- createArchive :: Verbosity+              -> ArchiveFormat               -> PackageDescription               -> FilePath               -> FilePath               -> IO FilePath-createArchive _verbosity pkg tmpDir targetPref = do-  let tarBallName     = display (packageId pkg)-      tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"-  createTarGzFile tarBallFilePath tmpDir tarBallName-  return tarBallFilePath+createArchive _verbosity TargzFormat pkg tmpDir targetPref = do+    createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)+    return tarBallFilePath+  where+    tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz"++createArchive verbosity ZipFormat pkg tmpDir targetPref = do+    createZipFile verbosity zipFilePath tmpDir (tarBallName pkg)+    return zipFilePath+  where+    zipFilePath = targetPref </> tarBallName pkg <.> "zip"++createZipFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO ()+createZipFile verbosity zipfile base dir = do+    (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb++    -- zip has an annoying habbit of updating the target rather than creating+    -- it from scratch. While that might sound like an optimisation, it doesn't+    -- remove files already in the archive that are no longer present in the+    -- uncompressed tree.+    alreadyExists <- doesFileExist zipfile+    when alreadyExists $ removeFile zipfile++    -- we call zip with a different CWD, so have to make the path absolute+    zipfileAbs <- canonicalizePath zipfile++    --TODO: use runProgramInvocation, but has to be able to set CWD+    hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just base)+                      Nothing Nothing Nothing Nothing+    exitCode <- waitForProcess hnd+    unless (exitCode == ExitSuccess) $+      die $ "Generating the zip file failed "+         ++ "(zip returned exit code " ++ show exitCode ++ ")"+  where+    zipProgram = simpleProgram "zip"

Distribution/Client/Tar.hs view

@@ -743,7 +743,7 @@ putString n s = take n s ++ fill (n - length s) '\NUL'  --TODO: check integer widths, eg for large file sizes-putOct :: Integral a => FieldWidth -> a -> String+putOct :: (Show a, Integral a) => FieldWidth -> a -> String putOct n x =   let octStr = take (n-1) $ showOct x ""    in fill (n - length octStr - 1) '0'

Distribution/Client/Targets.hs view

@@ -37,6 +37,11 @@   disambiguatePackageTargets,   disambiguatePackageName, +  -- * User constraints+  UserConstraint(..),+  readUserConstraint,+  userToPackageConstraint+   ) where  import Distribution.Package@@ -44,7 +49,7 @@          , PackageIdentifier(..), packageName, packageVersion          , Dependency(Dependency) ) import Distribution.Client.Types-         ( AvailablePackage(..), PackageLocation(..) )+         ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) import Distribution.Client.Dependency.Types          ( PackageConstraint(..) ) @@ -55,17 +60,14 @@ import Distribution.Client.FetchUtils  import Distribution.PackageDescription-         ( GenericPackageDescription )+         ( GenericPackageDescription, FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Parse          ( readPackageDescription, parsePackageDescription, ParseResult(..) )-import Distribution.Simple.Setup-         ( fromFlag )-import Distribution.Client.Setup-         ( GlobalFlags(..) ) import Distribution.Version-         ( Version(Version), thisVersion, anyVersion, isAnyVersion )+         ( Version(Version), thisVersion, anyVersion, isAnyVersion+         , VersionRange ) import Distribution.Text-         ( Text(parse), display )+         ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils          ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )@@ -84,9 +86,13 @@ import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Monad (liftM) import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, readP_to_S, (+++) )+import Distribution.Compat.ReadP+         ( (+++), (<++) )+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+         ( (<>), (<+>) ) import Data.Char-         ( isSpace )+         ( isSpace, isAlphaNum ) import System.FilePath          ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory@@ -180,7 +186,7 @@                         => PackageSpecifier pkg -> [PackageConstraint] pkgSpecifierConstraints (NamedPackage _ constraints) = constraints pkgSpecifierConstraints (SpecificSourcePackage pkg)  =-  [PackageVersionConstraint (packageName pkg)+  [PackageConstraintVersion (packageName pkg)                             (thisVersion (packageVersion pkg))]  @@ -269,16 +275,17 @@                       && takeExtension (dropExtension f) == ".tar"      parseDependencyOrPackageId :: Parse.ReadP r Dependency-    parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse+    parseDependencyOrPackageId = parse+                             +++ liftM pkgidToDependency parse       where         pkgidToDependency :: PackageIdentifier -> Dependency         pkgidToDependency p = case packageVersion p of           Version [] _ -> Dependency (packageName p) anyVersion           version      -> Dependency (packageName p) (thisVersion version) -    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a-    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str-                                         , all isSpace s ]+readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                     , all isSpace s ]   reportUserTargetProblems :: [UserTargetProblem] -> IO ()@@ -341,17 +348,17 @@ -- resolveUserTargets :: Package pkg                    => Verbosity-                   -> GlobalFlags+                   -> FilePath                    -> PackageIndex pkg                    -> [UserTarget]-                   -> IO [PackageSpecifier AvailablePackage]-resolveUserTargets verbosity globalFlags available userTargets = do+                   -> IO [PackageSpecifier SourcePackage]+resolveUserTargets verbosity worldFile available userTargets = do      -- given the user targets, get a list of fully or partially resolved     -- package references     packageTargets <- mapM (readPackageTarget verbosity)                   =<< mapM (fetchPackageTarget verbosity) . concat-                  =<< mapM (expandUserTarget globalFlags) userTargets+                  =<< mapM (expandUserTarget worldFile) userTargets      -- users are allowed to give package names case-insensitively, so we must     -- disambiguate named package references@@ -391,13 +398,13 @@ -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). ---expandUserTarget :: GlobalFlags+expandUserTarget :: FilePath                  -> UserTarget                  -> IO [PackageTarget (PackageLocation ())]-expandUserTarget globalFlags userTarget = case userTarget of+expandUserTarget worldFile userTarget = case userTarget of      UserTargetNamed (Dependency name vrange) ->-      let constraints = [ PackageVersionConstraint name vrange+      let constraints = [ PackageConstraintVersion name vrange                         | not (isAnyVersion vrange) ]       in  return [PackageTargetNamedFuzzy name constraints userTarget] @@ -406,9 +413,9 @@       --TODO: should we warn if there are no world targets?       return [ PackageTargetNamed name constraints userTarget              | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs-             , let constraints = [ PackageVersionConstraint name vrange+             , let constraints = [ PackageConstraintVersion name vrange                                  | not (isAnyVersion vrange) ]-                              ++ [ PackageFlagsConstraint name flags+                              ++ [ PackageConstraintFlags name flags                                  | not (null flags) ] ]      UserTargetLocalDir dir ->@@ -424,8 +431,6 @@      UserTargetRemoteTarball tarballURL ->       return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]-  where-    worldFile = fromFlag $ globalWorldFile globalFlags   -- ------------------------------------------------------------@@ -452,7 +457,7 @@ -- readPackageTarget :: Verbosity                   -> PackageTarget (PackageLocation FilePath)-                  -> IO (PackageTarget AvailablePackage)+                  -> IO (PackageTarget SourcePackage) readPackageTarget verbosity target = case target of      PackageTargetNamed pkgname constraints userTarget ->@@ -466,7 +471,7 @@       LocalUnpackedPackage dir -> do         pkg <- readPackageDescription verbosity =<< findPackageDesc dir         return $ PackageTargetLocation $-                   AvailablePackage {+                   SourcePackage {                      packageInfoId      = packageId pkg,                      packageDescription = pkg,                      packageSource      = fmap Just location@@ -491,7 +496,7 @@                        ++ filename ++ " in " ++ tarballFile         Just pkg ->           return $ PackageTargetLocation $-                     AvailablePackage {+                     SourcePackage {                        packageInfoId      = packageId pkg,                        packageDescription = pkg,                        packageSource      = fmap Just location@@ -552,14 +557,14 @@                            -> [PackageTarget pkg]                            -> ( [PackageTargetProblem]                               , [PackageSpecifier pkg] )-disambiguatePackageTargets available availableExtra targets =+disambiguatePackageTargets availablePkgIndex availableExtra targets =     partitionEithers (map disambiguatePackageTarget targets)   where     disambiguatePackageTarget packageTarget = case packageTarget of       PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)        PackageTargetNamed pkgname constraints userTarget-        | null (PackageIndex.lookupPackageName available pkgname)+        | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)                     -> Left (PackageNameUnknown pkgname userTarget)         | otherwise -> Right (NamedPackage pkgname constraints) @@ -569,11 +574,13 @@                                           pkgname userTarget)           Ambiguous   pkgnames -> Left  (PackageNameAmbigious                                           pkgname pkgnames userTarget)-          Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints)+          Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints')+            where+              constraints' = map (renamePackageConstraint pkgname') constraints      -- use any extra specific available packages to help us disambiguate     packageNameEnv :: PackageNameEnv-    packageNameEnv = mappend (indexPackageNameEnv available)+    packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)                              (extraPackageNameEnv availableExtra)  @@ -605,7 +612,7 @@                  "The following 'world' packages will be ignored because "               ++ "they refer to packages that cannot be found: "               ++ intercalate ", " (map display pkgs) ++ "\n"-              ++ "You can surpress this warning by correcting the world file."+              ++ "You can suppress this warning by correcting the world file."   where     isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False @@ -642,10 +649,10 @@     PackageNameEnv (\name -> lookupA name ++ lookupB name)  indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv-indexPackageNameEnv index = PackageNameEnv pkgNameLookup+indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup   where     pkgNameLookup (PackageName name) =-      map fst (PackageIndex.searchByName index name)+      map fst (PackageIndex.searchByName pkgIndex name)  extraPackageNameEnv :: [PackageName] -> PackageNameEnv extraPackageNameEnv names = PackageNameEnv pkgNameLookup@@ -655,3 +662,99 @@       | let lname = lowercase name       , PackageName name' <- names       , lowercase name' == lname ]+++-- ------------------------------------------------------------+-- * Package constraints+-- ------------------------------------------------------------++data UserConstraint =+     UserConstraintVersion   PackageName VersionRange+   | UserConstraintInstalled PackageName+   | UserConstraintSource    PackageName+   | UserConstraintFlags     PackageName FlagAssignment+   | UserConstraintStanzas   PackageName [OptionalStanza]+  deriving (Show,Eq)+++userToPackageConstraint :: UserConstraint -> PackageConstraint+-- At the moment, the types happen to be directly equivalent+userToPackageConstraint uc = case uc of+  UserConstraintVersion   name ver   -> PackageConstraintVersion    name ver+  UserConstraintInstalled name       -> PackageConstraintInstalled  name+  UserConstraintSource    name       -> PackageConstraintSource     name+  UserConstraintFlags     name flags -> PackageConstraintFlags      name flags+  UserConstraintStanzas   name stanzas -> PackageConstraintStanzas  name stanzas++renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint+renamePackageConstraint name pc = case pc of+  PackageConstraintVersion   _ ver   -> PackageConstraintVersion    name ver+  PackageConstraintInstalled _       -> PackageConstraintInstalled  name+  PackageConstraintSource    _       -> PackageConstraintSource     name+  PackageConstraintFlags     _ flags -> PackageConstraintFlags      name flags+  PackageConstraintStanzas   _ stanzas -> PackageConstraintStanzas   name stanzas++readUserConstraint :: String -> Either String UserConstraint+readUserConstraint str =+    case readPToMaybe parse str of+      Nothing -> Left msgCannotParse+      Just c  -> Right c+  where+    msgCannotParse =+         "expected a package name followed by a constraint, which is "+      ++ "either a version range, 'installed', 'source' or flags"++--FIXME: use Text instance for FlagName and FlagAssignment+instance Text UserConstraint where+  disp (UserConstraintVersion   pkgname verrange) = disp pkgname <+> disp verrange+  disp (UserConstraintInstalled pkgname)          = disp pkgname <+> Disp.text "installed"+  disp (UserConstraintSource    pkgname)          = disp pkgname <+> Disp.text "source"+  disp (UserConstraintFlags     pkgname flags)    = disp pkgname <+> dispFlagAssignment flags+    where+      dispFlagAssignment = Disp.hsep . map dispFlagValue+      dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f+      dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f+      dispFlagName (FlagName f) = Disp.text f++  disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname <+> dispStanzas stanzas+    where+      dispStanzas = Disp.hsep . map dispStanza+      dispStanza TestStanzas  = Disp.text "test"+      dispStanza BenchStanzas = Disp.text "bench"++  parse = parse >>= parseConstraint+    where+      spaces = Parse.satisfy isSpace >> Parse.skipSpaces++      parseConstraint pkgname =+            (parse >>= return . UserConstraintVersion pkgname)+        +++ (do spaces+                _ <- Parse.string "installed"+                return (UserConstraintInstalled pkgname))+        +++ (do spaces+                _ <- Parse.string "source"+                return (UserConstraintSource pkgname))+        +++ (do spaces+                _ <- Parse.string "test"+                return (UserConstraintStanzas pkgname [TestStanzas]))+        +++ (do spaces+                _ <- Parse.string "bench"+                return (UserConstraintStanzas pkgname [BenchStanzas]))+        <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))++      parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)+      parseFlagValue =+            (do Parse.optional (Parse.char '+')+                f <- parseFlagName+                return (f, True))+        +++ (do _ <- Parse.char '-'+                f <- parseFlagName+                return (f, False))+      parseFlagName = liftM FlagName ident++      ident :: Parse.ReadP r String+      ident = Parse.munch1 identChar >>= \s -> check s >> return s+        where+          identChar c   = isAlphaNum c || c == '_' || c == '-'+          check ('-':_) = Parse.pfail+          check _       = return ()

Distribution/Client/Types.hs view

@@ -18,7 +18,10 @@ import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import Distribution.PackageDescription-         ( GenericPackageDescription, FlagAssignment )+         ( Benchmark(..), GenericPackageDescription(..), FlagAssignment+         , TestSuite(..) )+import Distribution.PackageDescription.Configuration+         ( mapTreeData ) import Distribution.Client.PackageIndex          ( PackageIndex ) import Distribution.Version@@ -34,8 +37,8 @@  -- | This is the information we get from a @00-index.tar.gz@ hackage index. ---data AvailablePackageDb = AvailablePackageDb {-  packageIndex       :: PackageIndex AvailablePackage,+data SourcePackageDb = SourcePackageDb {+  packageIndex       :: PackageIndex SourcePackage,   packagePreferences :: Map PackageName VersionRange } @@ -72,32 +75,52 @@ -- final configure process will be independent of the environment. -- data ConfiguredPackage = ConfiguredPackage-       AvailablePackage    -- package info, including repo+       SourcePackage       -- package info, including repo        FlagAssignment      -- complete flag assignment for the package+       [OptionalStanza]    -- list of enabled optional stanzas for the package        [PackageId]         -- set of exact dependencies. These must be                            -- consistent with the 'buildDepends' in the-                           -- 'PackageDescrption' that you'd get by applying-                           -- the flag assignment.+                           -- 'PackageDescription' that you'd get by applying+                           -- the flag assignment and optional stanzas.   deriving Show  instance Package ConfiguredPackage where-  packageId (ConfiguredPackage pkg _ _) = packageId pkg+  packageId (ConfiguredPackage pkg _ _ _) = packageId pkg  instance PackageFixedDeps ConfiguredPackage where-  depends (ConfiguredPackage _ _ deps) = deps+  depends (ConfiguredPackage _ _ _ deps) = deps  --- | We re-use @GenericPackageDescription@ and use the @package-url@--- field to store the tarball URI.-data AvailablePackage = AvailablePackage {+-- | A package description along with the location of the package sources.+--+data SourcePackage = SourcePackage {     packageInfoId      :: PackageId,     packageDescription :: GenericPackageDescription,     packageSource      :: PackageLocation (Maybe FilePath)   }   deriving Show -instance Package AvailablePackage where packageId = packageInfoId+instance Package SourcePackage where packageId = packageInfoId +data OptionalStanza+    = TestStanzas+    | BenchStanzas+  deriving (Eq, Ord, Show)++enableStanzas+    :: [OptionalStanza]+    -> GenericPackageDescription+    -> GenericPackageDescription+enableStanzas stanzas gpkg = gpkg+    { condBenchmarks = flagBenchmarks $ condBenchmarks gpkg+    , condTestSuites = flagTests $ condTestSuites gpkg+    }+  where+    enableTest t = t { testEnabled = TestStanzas `elem` stanzas }+    enableBenchmark bm = bm { benchmarkEnabled = BenchStanzas `elem` stanzas }+    flagBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))+    flagTests = map (\(n, t) -> (n, mapTreeData enableTest t))+ -- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------@@ -156,8 +179,9 @@                   | UnpackFailed    SomeException                   | ConfigureFailed SomeException                   | BuildFailed     SomeException+                  | TestsFailed     SomeException                   | InstallFailed   SomeException data BuildSuccess = BuildOk         DocsResult TestsResult  data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk-data TestsResult = TestsNotTried | TestsFailed | TestsOk+data TestsResult = TestsNotTried | TestsOk

Distribution/Client/Unpack.hs view

@@ -21,7 +21,7 @@ import Distribution.Package          ( PackageId, packageId ) import Distribution.Simple.Setup-         ( fromFlagOrDefault )+         ( fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils          ( notice, die ) import Distribution.Verbosity@@ -36,7 +36,7 @@ import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils-        ( getAvailablePackages )+        ( getSourcePackages )  import System.Directory          ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )@@ -60,14 +60,16 @@ unpack verbosity repos globalFlags unpackFlags userTargets = do   mapM_ checkTarget userTargets -  availableDb   <- getAvailablePackages verbosity repos+  sourcePkgDb   <- getSourcePackages verbosity repos    pkgSpecifiers <- resolveUserTargets verbosity-                     globalFlags (packageIndex availableDb) userTargets+                     (fromFlag $ globalWorldFile globalFlags)+                     (packageIndex sourcePkgDb)+                     userTargets    pkgs <- either (die . unlines . map show) return $             resolveWithoutDependencies-              (resolverParams availableDb pkgSpecifiers)+              (resolverParams sourcePkgDb pkgSpecifiers)    unless (null prefix) $          createDirectoryIfMissing True prefix@@ -89,10 +91,10 @@         error "Distribution.Client.Unpack.unpack: the impossible happened."    where-    resolverParams availableDb pkgSpecifiers =+    resolverParams sourcePkgDb pkgSpecifiers =         --TODO: add commandline constraint and preference args for unpack -        standardInstallPolicy mempty availableDb pkgSpecifiers+        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers      prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)

Distribution/Client/Update.hs view

@@ -15,12 +15,12 @@     ) where  import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) )+         ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) ) import Distribution.Client.FetchUtils          ( downloadIndex ) import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.IndexUtils-         ( getAvailablePackages )+         ( getSourcePackages, updateRepoIndexCache ) import qualified Paths_cabal_install          ( version ) @@ -60,17 +60,18 @@     writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack                                               . maybeDecompress                                             =<< BS.readFile indexPath+    updateRepoIndexCache verbosity repo  checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () checkForSelfUpgrade verbosity repos = do-  AvailablePackageDb available prefs <- getAvailablePackages verbosity repos+  SourcePackageDb sourcePkgIndex prefs <- getSourcePackages verbosity repos    let self = PackageName "cabal-install"       preferredVersionRange  = fromMaybe anyVersion (Map.lookup self prefs)       currentVersion         = Paths_cabal_install.version       laterPreferredVersions =         [ packageVersion pkg-        | pkg <- PackageIndex.lookupPackageName available self+        | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self         , let version = packageVersion pkg         , version > currentVersion         , version `withinRange` preferredVersionRange ]

Distribution/Client/Upload.hs view

@@ -4,7 +4,7 @@ module Distribution.Client.Upload (check, upload, report) where  import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))-import Distribution.Client.HttpUtils (proxy, isOldHackageURI)+import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse)  import Distribution.Simple.Utils (debug, notice, warn, info) import Distribution.Verbosity (Verbosity)@@ -15,9 +15,8 @@ import qualified Distribution.Client.BuildReports.Upload as BuildReport  import Network.Browser-         ( BrowserAction, browse, request-         , Authority(..), addAuthority, setAuthorityGen-         , setOutHandler, setErrHandler, setProxy )+         ( BrowserAction, request+         , Authority(..), addAuthority ) import Network.HTTP          ( Header(..), HeaderName(..), findHeader          , Request(..), RequestMethod(..), Response(..) )@@ -33,7 +32,7 @@ import System.FilePath  ((</>), takeExtension, takeFileName) import qualified System.FilePath.Posix as FilePath.Posix (combine) import System.Directory-import Control.Monad (forM_)+import Control.Monad (forM_, when)   --FIXME: how do we find this path for an arbitrary hackage server?@@ -98,16 +97,19 @@         Left remoteRepo             -> do dotCabal <- defaultCabalDir                   let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo-                  contents <- getDirectoryContents srcDir-                  forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->-                      do inp <- readFile (srcDir </> logFile)-                         let (reportStr, buildLog) = read inp :: (String,String)-                         case BuildReport.parse reportStr of-                           Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME-                           Right report' ->-                               do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')-                                  browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth-                                  return ()+                  -- We don't want to bomb out just because we haven't built any packages from this repo yet+                  srcExists <- doesDirectoryExist srcDir+                  when srcExists $ do+                    contents <- getDirectoryContents srcDir+                    forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->+                        do inp <- readFile (srcDir </> logFile)+                           let (reportStr, buildLog) = read inp :: (String,String)+                           case BuildReport.parse reportStr of+                             Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME+                             Right report' ->+                                 do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')+                                    cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]+                                    return ()         Right{} -> return ()   where     targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given@@ -122,15 +124,8 @@               -> FilePath -> IO () handlePackage verbosity uri auth path =   do req <- mkRequest uri path-     p   <- proxy verbosity      debug verbosity $ "\n" ++ show req-     (_,resp) <- browse $ do-                   setProxy p-                   setErrHandler (warn verbosity . ("http error: "++))-                   setOutHandler (debug verbosity)-                   auth-                   setAuthorityGen (\_ _ -> return Nothing)-                   request req+     (_,resp) <- cabalBrowse verbosity auth $ request req      debug verbosity $ show resp      case rspCode resp of        (2,0,0) -> do notice verbosity "Ok"

Main.hs view

@@ -16,7 +16,7 @@ import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand, globalRepos          , ConfigFlags(..)-         , ConfigExFlags(..), configureExCommand+         , ConfigExFlags(..), defaultConfigExFlags, configureExCommand          , InstallFlags(..), defaultInstallFlags          , installCommand, upgradeCommand          , FetchFlags(..), fetchCommand@@ -26,7 +26,8 @@          , InfoFlags(..), infoCommand          , UploadFlags(..), uploadCommand          , ReportFlags(..), reportCommand-         , InitFlags, initCommand+         , InitFlags(initVerbosity), initCommand+         , SDistFlags(..), SDistExFlags(..), sdistCommand          , reportCommand          , unpackCommand, UnpackFlags(..) ) import Distribution.Simple.Setup@@ -36,8 +37,8 @@          , CopyFlags(..), copyCommand          , RegisterFlags(..), registerCommand          , CleanFlags(..), cleanCommand-         , SDistFlags(..), sdistCommand          , TestFlags(..), testCommand+         , BenchmarkFlags(..), benchmarkCommand          , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )  import Distribution.Client.SetupWrapper@@ -150,6 +151,8 @@                      regVerbosity      regDistPref       ,wrapperAction testCommand                      testVerbosity     testDistPref+      ,wrapperAction benchmarkCommand+                     benchmarkVerbosity     benchmarkDistPref       ,upgradeCommand         `commandAddAction` upgradeAction       ] @@ -184,29 +187,30 @@             (configPackageDB' configFlags') (globalRepos globalFlags')             comp conf configFlags' configExFlags' extraArgs -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO ()-installAction (configFlags, _, installFlags) _ _globalFlags+installAction (configFlags, _, installFlags, _) _ _globalFlags   | fromFlagOrDefault False (installOnly installFlags)   = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)     in setupWrapper verbosity defaultSetupScriptOptions Nothing          installCommand (const mempty) [] -installAction (configFlags, configExFlags, installFlags)+installAction (configFlags, configExFlags, installFlags, haddockFlags)               extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)   targets <- readUserTargets verbosity extraArgs   config <- loadConfig verbosity (globalConfigFile globalFlags)                                  (configUserInstall configFlags)   let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      configExFlags' = defaultConfigExFlags         `mappend`+                       savedConfigureExFlags config `mappend` configExFlags       installFlags'  = defaultInstallFlags          `mappend`                        savedInstallFlags     config `mappend` installFlags       globalFlags'   = savedGlobalFlags      config `mappend` globalFlags   (comp, conf) <- configCompilerAux' configFlags'   install verbosity           (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags'+          comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags           targets  listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()@@ -250,9 +254,9 @@   let globalFlags' = savedGlobalFlags config `mappend` globalFlags   update verbosity (globalRepos globalFlags') -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO ()-upgradeAction (configFlags, configExFlags, installFlags)+upgradeAction (configFlags, configExFlags, installFlags, haddockFlags)               extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)   targets <- readUserTargets verbosity extraArgs@@ -266,7 +270,7 @@   (comp, conf) <- configCompilerAux' configFlags'   upgrade verbosity           (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags'+          comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags           targets  fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()@@ -322,11 +326,11 @@   unless allOk exitFailure  -sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()-sdistAction sflags extraArgs _globalFlags = do+sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO ()+sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do   unless (null extraArgs) $ do     die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs-  sdist sflags+  sdist sdistFlags sdistExFlags  reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do@@ -355,8 +359,16 @@          targets  initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()-initAction flags _extraArgs _globalFlags = do-  initCabal flags+initAction initFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (initVerbosity initFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+  (comp, conf) <- configCompilerAux' configFlags+  initCabal verbosity+            (configPackageDB' configFlags)+            comp+            conf+            initFlags  -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --

README view

@@ -17,13 +17,10 @@ is sometimes packaged separately by Linux distributions, for example on debian or ubuntu it is in "libghc6-network-dev". -It requires a few other Haskell packages that are not always installed:-- * Cabal  (version 1.10 or later)- * HTTP   (version 4000 or later)- * zlib   (version 0.4  or later)--All of these are available from [Hackage](http://hackage.haskell.org).+It requires a few other Haskell packages that are not always installed.+The exact list is specified in the `.cabal` file or in the `bootstrap.sh`+file. All these packages are available from+[Hackage](http://hackage.haskell.org).  Note that on some Unix systems you may need to install an additional zlib development package using your system package manager, for example on@@ -45,7 +42,7 @@      $ ./bootstrap.sh -It will download and install the above three dependencies. The script will+It will download and install the dependencies. The script will install the library packages into `$HOME/.cabal/` and the `cabal` program will be installed into `$HOME/.cabal/bin/`. @@ -139,13 +136,6 @@ By default it installs the latest available version however you can optionally specify exact versions or version ranges. For example `cabal install alex-2.2` or `cabal install parsec < 3`.--    $ cabal upgrade xmonad--This is a variation on the `install` command. Both mean to install the latest-version, the only difference is in the treatment of dependencies. The `install`-command tries to use existing installed versions of dependent packages while-the `upgrade` command tries to upgrade all the dependencies too.      $ cabal list xml

bootstrap.sh view

@@ -7,7 +7,6 @@ # It expects to be run inside the cabal-install directory.  # install settings, you can override these by setting environment vars-PREFIX=${PREFIX:-${HOME}/.cabal} #VERBOSE #EXTRA_CONFIGURE_OPTS @@ -20,6 +19,7 @@ TAR=${TAR:-tar} GUNZIP=${GUNZIP:-gunzip} SCOPE_OF_INSTALLATION="--user"+DEFAULT_PREFIX="${HOME}/.cabal"   for arg in $*@@ -30,7 +30,7 @@       shift;;     "--global")       SCOPE_OF_INSTALLATION=${arg}-      PREFIX="/usr/local"+      DEFAULT_PREFIX="/usr/local"       shift;;     *)       echo "Unknown argument or option, quitting: ${arg}"@@ -43,17 +43,21 @@   esac done +PREFIX=${PREFIX:-${DEFAULT_PREFIX}}  # Versions of the packages to install. # The version regex says what existing installed versions are ok.-PARSEC_VER="3.1.1";    PARSEC_VER_REGEXP="[23]\."  # == 2.* || == 3.*-NETWORK_VER="2.3.0.2"; NETWORK_VER_REGEXP="2\."    # == 2.*-CABAL_VER="1.10.1.0";  CABAL_VER_REGEXP="1\.10\.[^0]"  # == 1.10.* && >= 1.10.1-TRANS_VER="0.2.2.0";   TRANS_VER_REGEXP="0\.2\."   # == 0.2.*-MTL_VER="2.0.1.0";     MTL_VER_REGEXP="[12]\."     # == 1.* || == 2.*-HTTP_VER="4000.1.1";   HTTP_VER_REGEXP="4000\.[01]\." # == 4000.0.* || 4000.1.*-ZLIB_VER="0.5.3.1";    ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.*-TIME_VER="1.2.0.4"     TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.*+PARSEC_VER="3.1.2";    PARSEC_VER_REGEXP="[23]\."  # == 2.* || == 3.*+DEEPSEQ_VER="1.3.0.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2+TEXT_VER="0.11.2.0";  TEXT_VER_REGEXP="0\.([2-9]|(1[0-1]))\." # >= 0.2 && < 0.12+NETWORK_VER="2.3.0.11"; NETWORK_VER_REGEXP="2\."    # == 2.*+CABAL_VER="1.14.0";    CABAL_VER_REGEXP="1\.(13\.3|14\.)"  # >= 1.13.3 && < 1.15+TRANS_VER="0.3.0.0";   TRANS_VER_REGEXP="0\.[23]\."   # >= 0.2.* && < 0.4.*+MTL_VER="2.1";     MTL_VER_REGEXP="[12]\."     # == 1.* || == 2.*+HTTP_VER="4000.2.3";   HTTP_VER_REGEXP="4000\.[012]\." # == 4000.0.* || 4000.1.* || 4000.2.*+ZLIB_VER="0.5.3.3";    ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || == 0.5.*+TIME_VER="1.4"         TIME_VER_REGEXP="1\.[1234]\.?" # >= 1.1 && < 1.5+RANDOM_VER="1.0.1.1"   RANDOM_VER_REGEXP="1\.0\." # >= 1 && < 1.1  HACKAGE_URL="http://hackage.haskell.org/packages/archive" @@ -86,7 +90,7 @@ need_pkg () {   PKG=$1   VER_MATCH=$2-  if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1+  if egrep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1   then     return 1;   else@@ -186,20 +190,26 @@ info_pkg "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP} info_pkg "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP} info_pkg "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}+info_pkg "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP}+info_pkg "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP} info_pkg "time"         ${TIME_VER}    ${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}  do_pkg   "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP} do_pkg   "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP} do_pkg   "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}+do_pkg   "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_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} do_pkg   "time"         ${TIME_VER}    ${TIME_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}  install_pkg "cabal-install"

cabal-install.cabal view

@@ -1,5 +1,5 @@ Name:               cabal-install-Version:            0.10.2+Version:            0.14.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -19,7 +19,7 @@                     2006 Paolo Martini <paolo@nemail.it>                     2007 Bjorn Bringert <bjorn@bringert.net>                     2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    2007-2011 Duncan Coutts <duncan@community.haskell.org>+                    2007-2012 Duncan Coutts <duncan@community.haskell.org> Category:           Distribution Build-type:         Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh@@ -27,12 +27,8 @@  source-repository head   type:     darcs-  location: http://darcs.haskell.org/cabal-install/--source-repository this-  type:     darcs-  location: http://darcs.haskell.org/cabal-branches/cabal-install-0.10/-  tag:      0.10.0+  location: http://darcs.haskell.org/cabal/+  subdir:   cabal-install  flag old-base   description: Old, monolithic base@@ -42,9 +38,7 @@  Executable cabal     Main-Is:            Main.hs-    -- We want assertion checking on even if people build with -O-    -- although it is expensive, we want to catch problems early:-    ghc-options:        -Wall -fno-ignore-asserts+    ghc-options:        -Wall     if impl(ghc >= 6.8)       ghc-options: -fwarn-tabs     Other-Modules:@@ -60,6 +54,25 @@         Distribution.Client.Dependency.TopDown.Constraints         Distribution.Client.Dependency.TopDown.Types         Distribution.Client.Dependency.Types+        Distribution.Client.Dependency.Modular+        Distribution.Client.Dependency.Modular.Assignment+        Distribution.Client.Dependency.Modular.Builder+        Distribution.Client.Dependency.Modular.Configured+        Distribution.Client.Dependency.Modular.ConfiguredConversion+        Distribution.Client.Dependency.Modular.Dependency+        Distribution.Client.Dependency.Modular.Explore+        Distribution.Client.Dependency.Modular.Flag+        Distribution.Client.Dependency.Modular.Index+        Distribution.Client.Dependency.Modular.IndexConversion+        Distribution.Client.Dependency.Modular.Log+        Distribution.Client.Dependency.Modular.Message+        Distribution.Client.Dependency.Modular.Package+        Distribution.Client.Dependency.Modular.Preference+        Distribution.Client.Dependency.Modular.PSQ+        Distribution.Client.Dependency.Modular.Solver+        Distribution.Client.Dependency.Modular.Tree+        Distribution.Client.Dependency.Modular.Validate+        Distribution.Client.Dependency.Modular.Version         Distribution.Client.Fetch         Distribution.Client.FetchUtils         Distribution.Client.GZipUtils@@ -93,24 +106,25 @@         Paths_cabal_install      build-depends: base     >= 2        && < 5,-                   Cabal    >= 1.10.1   && < 1.11,-                   filepath >= 1.0      && < 1.3,+                   Cabal    >= 1.14.0   && < 1.15,+                   filepath >= 1.0      && < 1.4,                    network  >= 1        && < 3,                    HTTP     >= 4000.0.2 && < 4001,                    zlib     >= 0.4      && < 0.6,-                   time     >= 1.1      && < 1.3+                   time     >= 1.1      && < 1.5,+                   mtl      >= 2.0      && < 3      if flag(old-base)       build-depends: base < 3     else       build-depends: base       >= 3,-                     process    >= 1   && < 1.1,+                     process    >= 1   && < 1.2,                      directory  >= 1   && < 1.2,-                     pretty     >= 1   && < 1.1,+                     pretty     >= 1   && < 1.2,                      random     >= 1   && < 1.1,                      containers >= 0.1 && < 0.5,-                     array      >= 0.1 && < 0.4,-                     old-time   >= 1   && < 1.1+                     array      >= 0.1 && < 0.5,+                     old-time   >= 1   && < 1.2      if flag(bytestring-in-base)       build-depends: base >= 2.0 && < 2.2@@ -121,5 +135,5 @@       build-depends: Win32 >= 2 && < 3       cpp-options: -DWIN32     else-      build-depends: unix >= 1.0 && < 2.5+      build-depends: unix >= 1.0 && < 2.6     extensions: CPP