Sun Oct 18 18:32:33 BST 2009 Duncan Coutts * Update for changes to finalizePackageDescription Thu Oct 22 13:39:46 BST 2009 Duncan Coutts * Initial go at converting to the new Cabal-1.8 installed package system It works by ignoring the possibility that there could be multiple installed packages sharing the same source package Id. We just pick the "top most" one which is usually ok. We make no attempt to check that we are using consistent installed packages. New patches: [Update for changes to finalizePackageDescription Duncan Coutts **20091018173233 Ignore-this: f60d2b66f9f0e223599ab15ac78d112c ] { hunk ./Distribution/Client/Configure.hs 67 import Distribution.Simple.Utils as Utils ( notice, info, die ) import Distribution.System - ( Platform(Platform), buildPlatform ) + ( Platform, buildPlatform ) import Distribution.Verbosity as Verbosity ( Verbosity ) hunk ./Distribution/Client/Configure.hs 194 -> ConfiguredPackage -> [String] -> IO () -configurePackage verbosity (Platform arch os) comp scriptOptions configFlags +configurePackage verbosity platform comp scriptOptions configFlags (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs = setupWrapper verbosity hunk ./Distribution/Client/Configure.hs 208 } pkg = case finalizePackageDescription flags - (Nothing :: Maybe (PackageIndex PackageDescription)) - os arch comp [] gpkg of + (const True) + platform comp [] gpkg of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc hunk ./Distribution/Client/Dependency/Bogus.hs 40 ( comparing ) import Distribution.Text ( display ) -import Distribution.System - ( Platform(Platform) ) import Data.List ( maximumBy ) hunk ./Distribution/Client/Dependency/Bogus.hs 53 -- We just pretend that everything is installed and hope for the best. -- bogusResolver :: DependencyResolver -bogusResolver (Platform arch os) comp _ available +bogusResolver platform comp _ available preferences constraints targets = resolveFromAvailable [] (combineConstraints preferences constraints targets) hunk ./Distribution/Client/Dependency/Bogus.hs 63 case latestAvailableSatisfying available name verConstraint verPref of Nothing -> Fail ("Unresolved dependency: " ++ display dep) Just apkg@(AvailablePackage _ pkg _) -> - case finalizePackageDescription flags none os arch comp [] pkg of + case finalizePackageDescription flags none platform comp [] pkg of Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps) where msg = "selecting " ++ display (packageId pkg) hunk ./Distribution/Client/Dependency/Bogus.hs 71 chosen' = InstallPlan.Configured cpkg : chosen _ -> error "bogusResolver: impossible happened" where - none :: Maybe (PackageIndex PackageIdentifier) - none = Nothing + none :: Dependency -> Bool + none = const True where dep = Dependency name verConstraint hunk ./Distribution/Client/Dependency/TopDown.hs 49 import Distribution.Compiler ( CompilerId ) import Distribution.System - ( Platform(Platform) ) + ( Platform ) import Distribution.Simple.Utils ( equating, comparing ) import Distribution.Text hunk ./Distribution/Client/Dependency/TopDown.hs 294 Fail (TopLevelInstallConstraintConflict pkg conflicts) configurePackage :: Platform -> CompilerId -> ConfigurePackage -configurePackage (Platform arch os) comp available spkg = case spkg of +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) hunk ./Distribution/Client/Dependency/TopDown.hs 301 (configure apkg) where configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) = - case finalizePackageDescription flags (Just available) os arch comp [] p of + case finalizePackageDescription flags dependencySatisfiable + platform comp [] p of Left missing -> Left missing Right (pkg, flags') -> Right $ SemiConfiguredPackage apkg flags' (buildDepends pkg) hunk ./Distribution/Client/Dependency/TopDown.hs 307 + dependencySatisfiable = not . null . PackageIndex.lookupDependency available + -- | Annotate each installed packages with its set of transative dependencies -- and its topological sort number. -- hunk ./Distribution/Client/Install.hs 113 import Distribution.Client.Utils ( inDir, mergeBy, MergeResult(..), withTempDirectory ) import Distribution.System - ( Platform(Platform), buildPlatform, OS(Windows), buildOS ) + ( Platform, buildPlatform, OS(Windows), buildOS ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity hunk ./Distribution/Client/Install.hs 587 -> (ConfigFlags -> AvailablePackageSource -> PackageDescription -> a) -> a -installConfiguredPackage (Platform arch os) comp configFlags +installConfiguredPackage platform comp configFlags (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps) installPkg = installPkg configFlags { configConfigurationsFlags = flags, hunk ./Distribution/Client/Install.hs 595 } source pkg where pkg = case finalizePackageDescription flags - (Nothing :: Maybe (PackageIndex PackageDescription)) - os arch comp [] gpkg of + (const True) + platform comp [] gpkg of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc hunk ./Distribution/Client/InstallPlan.hs 68 import Distribution.Text ( display ) import Distribution.System - ( Platform(Platform) ) + ( Platform ) import Distribution.Compiler ( CompilerId(..) ) import Distribution.Client.Utils hunk ./Distribution/Client/InstallPlan.hs 458 configuredPackageProblems :: Platform -> CompilerId -> ConfiguredPackage -> [PackageProblem] -configuredPackageProblems (Platform arch os) comp +configuredPackageProblems platform comp (ConfiguredPackage pkg specifiedFlags specifiedDeps) = [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] hunk ./Distribution/Client/InstallPlan.hs 490 requiredDeps = --TODO: use something lower level than finalizePackageDescription case finalizePackageDescription specifiedFlags - (Nothing :: Maybe (PackageIndex PackageIdentifier)) os arch comp [] + (const True) + platform comp + [] (packageDescription pkg) of Right (resolvedPkg, _) -> buildDepends resolvedPkg Left _ -> error "configuredPackageInvalidDeps internal error" hunk ./Distribution/Client/InstallSymlink.hs 61 import Distribution.Simple.Setup ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.System - ( Platform(Platform) ) import System.Posix.Files ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink hunk ./Distribution/Client/InstallSymlink.hs 135 pkgDescription :: ConfiguredPackage -> PackageDescription pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) = case finalizePackageDescription flags - (Nothing :: Maybe (PackageIndex PackageDescription)) - os arch compilerId [] pkg of + (const True) + platform compilerId [] pkg of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc hunk ./Distribution/Client/InstallSymlink.hs 162 fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - (Platform arch os) = InstallPlan.planPlatform plan + platform = InstallPlan.planPlatform plan compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir } [Initial go at converting to the new Cabal-1.8 installed package system Duncan Coutts **20091022123946 Ignore-this: 5e6665609e707de9dc73612b0efd25e9 It works by ignoring the possibility that there could be multiple installed packages sharing the same source package Id. We just pick the "top most" one which is usually ok. We make no attempt to check that we are using consistent installed packages. ] { hunk ./Distribution/Client/Configure.hs 30 import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages ) + ( getAvailablePackages, getInstalledPackages ) import Distribution.Client.Setup ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) import Distribution.Client.Types as Available hunk ./Distribution/Client/Configure.hs 35 ( AvailablePackage(..), AvailablePackageSource(..), Repo(..) - , AvailablePackageDb(..), ConfiguredPackage(..) ) + , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage ) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) hunk ./Distribution/Client/Configure.hs 43 ( CompilerId(..), Compiler(compilerId) , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) -import Distribution.Simple.Configure (getInstalledPackages) import Distribution.Simple.Setup ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) hunk ./Distribution/Client/Configure.hs 45 -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Simple.Utils ( defaultPackageDesc ) import Distribution.Package hunk ./Distribution/Client/Configure.hs 52 ( PackageName, packageName, packageVersion , Package(..), Dependency(..), thisPackageVersion ) -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.PackageDescription.Configuration hunk ./Distribution/Client/Configure.hs 56 ( finalizePackageDescription ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) import Distribution.Version ( VersionRange, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils hunk ./Distribution/Client/Configure.hs 131 -- planLocalPackage :: Verbosity -> Compiler -> ConfigFlags -> ConfigExFlags - -> Maybe (PackageIndex InstalledPackageInfo) + -> Maybe (PackageIndex InstalledPackage) -> AvailablePackageDb -> IO (Progress String String InstallPlan) planLocalPackage verbosity comp configFlags configExFlags installed hunk ./Distribution/Client/Dependency.hs 32 import Distribution.Client.Dependency.Bogus (bogusResolver) import Distribution.Client.Dependency.TopDown (topDownResolver) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Types hunk ./Distribution/Client/Dependency.hs 37 - ( UnresolvedDependency(..), AvailablePackage(..) ) + ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage ) import Distribution.Client.Dependency.Types ( DependencyResolver, PackageConstraint(..) , PackagePreferences(..), InstalledPreference(..) hunk ./Distribution/Client/Dependency.hs 46 ( PackageIdentifier(..), PackageName(..), packageVersion, packageName , Dependency(..), Package(..), PackageFixedDeps(..) ) import Distribution.Version - ( VersionRange(AnyVersion), orLaterVersion, isAnyVersion ) + ( VersionRange, anyVersion, orLaterVersion, isAnyVersion ) import Distribution.Compiler ( CompilerId(..) ) import Distribution.System hunk ./Distribution/Client/Dependency.hs 115 resolveDependencies :: Platform -> CompilerId - -> Maybe (PackageIndex InstalledPackageInfo) + -> Maybe (PackageIndex InstalledPackage) -> PackageIndex AvailablePackage -> PackagesPreference -> [PackageConstraint] hunk ./Distribution/Client/Dependency.hs 129 resolveDependenciesWithProgress :: Platform -> CompilerId - -> Maybe (PackageIndex InstalledPackageInfo) + -> Maybe (PackageIndex InstalledPackage) -> PackageIndex AvailablePackage -> PackagesPreference -> [PackageConstraint] hunk ./Distribution/Client/Dependency.hs 154 dependencyResolver :: DependencyResolver -> Platform -> CompilerId - -> PackageIndex InstalledPackageInfo + -> PackageIndex InstalledPackage -> PackageIndex AvailablePackage -> PackagesPreference -> [PackageConstraint] hunk ./Distribution/Client/Dependency.hs 197 where versionPref pkgname = - fromMaybe AnyVersion (Map.lookup pkgname versionPrefs) + fromMaybe anyVersion (Map.lookup pkgname versionPrefs) versionPrefs = Map.fromList [ (pkgname, pref) | PackageVersionPreference pkgname pref <- prefs ] hunk ./Distribution/Client/Dependency.hs 219 -- | Given the list of installed packages and available packages, figure -- out which packages can be upgraded. -- -upgradableDependencies :: PackageIndex InstalledPackageInfo +upgradableDependencies :: PackageIndex InstalledPackage -> PackageIndex AvailablePackage -> [Dependency] upgradableDependencies installed available = hunk ./Distribution/Client/Dependency/Bogus.hs 32 ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Version ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Simple.Utils hunk ./Distribution/Client/Dependency/TopDown.hs 25 import Distribution.Client.InstallPlan ( PlanPackage(..) ) import Distribution.Client.Types - ( AvailablePackage(..), ConfiguredPackage(..) ) + ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) ) import Distribution.Client.Dependency.Types ( DependencyResolver, PackageConstraint(..) , PackagePreferences(..), InstalledPreference(..) hunk ./Distribution/Client/Dependency/TopDown.hs 31 , Progress(..), foldProgress ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) +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 hunk ./Distribution/Client/Dependency/TopDown.hs 74 -- ------------------------------------------------------------ type Constraints = Constraints.Constraints - InstalledPackage UnconfiguredPackage ExclusionReason + InstalledPackageEx UnconfiguredPackage ExclusionReason type SelectedPackages = PackageIndex SelectedPackage -- ------------------------------------------------------------ hunk ./Distribution/Client/Dependency/TopDown.hs 106 (_, node') = maximumBy (bestByPref pkgname) choice where topSortNumber choice = case fst (head choice) of - InstalledOnly (InstalledPackage _ i _) -> i + InstalledOnly (InstalledPackageEx _ i _) -> i AvailableOnly (UnconfiguredPackage _ i _) -> i InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i hunk ./Distribution/Client/Dependency/TopDown.hs 187 preferAvailable (InstalledOnly pkg) = Left pkg preferAvailable (AvailableOnly pkg) = Right pkg preferAvailable (InstalledAndAvailable _ pkg) = Right pkg - installedConstraints (InstalledPackage _ _ deps) = + installedConstraints (InstalledPackageEx _ _ deps) = [ TaggedDependency InstalledConstraint (thisPackageVersion dep) | dep <- deps ] availableConstraints (SemiConfiguredPackage _ _ deps) = hunk ./Distribution/Client/Dependency/TopDown.hs 235 -- | The native resolver with detailed structured logging and failure types. -- topDownResolver' :: Platform -> CompilerId - -> PackageIndex InstalledPackageInfo + -> PackageIndex InstalledPackage -> PackageIndex AvailablePackage -> (PackageName -> PackagePreferences) -> [PackageConstraint] hunk ./Distribution/Client/Dependency/TopDown.hs 249 where configure = configurePackage platform comp + constraintSet :: Constraints constraintSet = Constraints.empty (annotateInstalledPackages topSortNumber installed') (annotateAvailablePackages constraints topSortNumber available') hunk ./Distribution/Client/Dependency/TopDown.hs 312 -- and its topological sort number. -- annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) - -> PackageIndex InstalledPackageInfo -> PackageIndex InstalledPackage hunk ./Distribution/Client/Dependency/TopDown.hs 313 + -> PackageIndex InstalledPackageEx annotateInstalledPackages dfsNumber installed = PackageIndex.fromList hunk ./Distribution/Client/Dependency/TopDown.hs 315 - [ InstalledPackage pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) + [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) | pkg <- PackageIndex.allPackages installed ] where hunk ./Distribution/Client/Dependency/TopDown.hs 318 - transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier] + transitiveDepends :: InstalledPackage -> [PackageIdentifier] transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph . fromJust . toVertex . packageId (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed hunk ./Distribution/Client/Dependency/TopDown.hs 360 -- edges and even cycles, but that doesn't really matter here, it's only a -- heuristic. -- -topologicalSortNumbering :: PackageIndex InstalledPackageInfo +topologicalSortNumbering :: PackageIndex InstalledPackage -> PackageIndex AvailablePackage -> (PackageName -> TopologicalSortNumber) topologicalSortNumbering installed available = hunk ./Distribution/Client/Dependency/TopDown.hs 387 -- each index that we could possibly ever need. Do this by flattening packages -- and looking at the names of all possible dependencies. -- -selectNeededSubset :: PackageIndex InstalledPackageInfo +selectNeededSubset :: PackageIndex InstalledPackage -> PackageIndex AvailablePackage -> Set PackageName hunk ./Distribution/Client/Dependency/TopDown.hs 390 - -> (PackageIndex InstalledPackageInfo + -> (PackageIndex InstalledPackage ,PackageIndex AvailablePackage) selectNeededSubset installed available = select mempty mempty where hunk ./Distribution/Client/Dependency/TopDown.hs 394 - select :: PackageIndex InstalledPackageInfo + select :: PackageIndex InstalledPackage -> PackageIndex AvailablePackage -> Set PackageName hunk ./Distribution/Client/Dependency/TopDown.hs 397 - -> (PackageIndex InstalledPackageInfo + -> (PackageIndex InstalledPackage ,PackageIndex AvailablePackage) select installed' available' remaining | Set.null remaining = (installed', available') hunk ./Distribution/Client/Dependency/TopDown.hs 444 Just (InstalledOnly _) -> finaliseInstalled ipkg Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg - finaliseInstalled (InstalledPackage pkg _ _) = InstallPlan.PreExisting pkg + finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = InstallPlan.Configured (ConfiguredPackage pkg flags deps') where hunk ./Distribution/Client/Dependency/TopDown.hs 464 -- Is the package already used by the installed version of this -- package? If so we should pick that first. This stops us from doing -- silly things like deciding to rebuild haskell98 against base 3. - isCurrent = case mipkg :: Maybe InstalledPackage of + isCurrent = case mipkg :: Maybe InstalledPackageEx of Nothing -> \_ -> False Just ipkg -> \p -> packageId p `elem` depends ipkg -- If there is no upper bound on the version range then we apply a hunk ./Distribution/Client/Dependency/TopDown.hs 496 -- This may add additional constraints due to the dependencies of installed -- packages on other installed packages. -- -improvePlan :: PackageIndex InstalledPackageInfo +improvePlan :: PackageIndex InstalledPackage -> Constraints -> PackageIndex PlanPackage -> (PackageIndex PlanPackage, Constraints) hunk ./Distribution/Client/Dependency/TopDown.hs 523 _ -> False tryInstalled :: PackageIndex PlanPackage -> Constraints - -> [InstalledPackageInfo] + -> [InstalledPackage] -> Maybe (PackageIndex PlanPackage, Constraints) tryInstalled selected constraints [] = Just (selected, constraints) tryInstalled selected constraints (pkg:pkgs) = hunk ./Distribution/Client/Dependency/TopDown/Constraints.hs 25 ) where import Distribution.Client.Dependency.TopDown.Types -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Package ( PackageName, PackageIdentifier(..) , Package(packageId), packageName, packageVersion hunk ./Distribution/Client/Dependency/TopDown/Types.hs 16 module Distribution.Client.Dependency.TopDown.Types where import Distribution.Client.Types - ( AvailablePackage(..) ) + ( AvailablePackage(..), InstalledPackage ) hunk ./Distribution/Client/Dependency/TopDown/Types.hs 18 -import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Package ( PackageIdentifier, Dependency , Package(packageId), PackageFixedDeps(depends) ) hunk ./Distribution/Client/Dependency/TopDown/Types.hs 29 -- ------------------------------------------------------------ type SelectablePackage - = InstalledOrAvailable InstalledPackage UnconfiguredPackage + = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage type SelectedPackage hunk ./Distribution/Client/Dependency/TopDown/Types.hs 32 - = InstalledOrAvailable InstalledPackage SemiConfiguredPackage + = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage data InstalledOrAvailable installed available = InstalledOnly installed hunk ./Distribution/Client/Dependency/TopDown/Types.hs 41 type TopologicalSortNumber = Int -data InstalledPackage - = InstalledPackage - InstalledPackageInfo +data InstalledPackageEx + = InstalledPackageEx + InstalledPackage !TopologicalSortNumber hunk ./Distribution/Client/Dependency/TopDown/Types.hs 45 - [PackageIdentifier] + [PackageIdentifier] -- transative closure of installed deps data UnconfiguredPackage = UnconfiguredPackage hunk ./Distribution/Client/Dependency/TopDown/Types.hs 60 [Dependency] -- dependencies we end up with when we apply -- the flag assignment -instance Package InstalledPackage where - packageId (InstalledPackage p _ _) = packageId p +instance Package InstalledPackageEx where + packageId (InstalledPackageEx p _ _) = packageId p hunk ./Distribution/Client/Dependency/TopDown/Types.hs 63 -instance PackageFixedDeps InstalledPackage where - depends (InstalledPackage _ _ deps) = deps +instance PackageFixedDeps InstalledPackageEx where + depends (InstalledPackageEx _ _ deps) = deps instance Package UnconfiguredPackage where packageId (UnconfiguredPackage p _ _) = packageId p hunk ./Distribution/Client/Dependency/Types.hs 25 ) where import Distribution.Client.Types - ( AvailablePackage(..) ) + ( AvailablePackage(..), InstalledPackage ) import qualified Distribution.Client.InstallPlan as InstallPlan hunk ./Distribution/Client/Dependency/Types.hs 28 -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) import Distribution.PackageDescription ( FlagAssignment ) hunk ./Distribution/Client/Dependency/Types.hs 30 -import Distribution.Simple.PackageIndex +import Distribution.Client.PackageIndex ( PackageIndex ) import Distribution.Package ( PackageName ) hunk ./Distribution/Client/Dependency/Types.hs 53 -- type DependencyResolver = Platform -> CompilerId - -> PackageIndex InstalledPackageInfo + -> PackageIndex InstalledPackage -> PackageIndex AvailablePackage -> (PackageName -> PackagePreferences) -> [PackageConstraint] hunk ./Distribution/Client/Fetch.hs 36 import Distribution.Client.Dependency.Types ( foldProgress ) import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies ) + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.HttpUtils (getHTTP, isOldHackageURI) import Distribution.Client.Utils hunk ./Distribution/Client/Fetch.hs 45 import Distribution.Package ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) -import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Simple.Compiler ( Compiler(compilerId), PackageDBStack ) import Distribution.Simple.Program hunk ./Distribution/Client/Fetch.hs 50 ( ProgramConfiguration ) -import Distribution.Simple.Configure - ( getInstalledPackages ) import Distribution.Simple.Utils ( die, notice, info, debug, setupMessage , copyFileVerbose ) hunk ./Distribution/Client/Haddock.hs 31 import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Text (display) -import Distribution.Simple.PackageIndex(PackageIndex, allPackages, +import Distribution.Client.PackageIndex(PackageIndex, allPackages, allPackagesByName, fromList) import Distribution.Simple.Utils ( comparing, intercalate, debug hunk ./Distribution/Client/Haddock.hs 37 , installDirectoryContents, withTempDirectory ) import Distribution.InstalledPackageInfo as InstalledPackageInfo - (InstalledPackageInfo,InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed, package)) + ( InstalledPackageInfo + , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) +import Distribution.Client.Types + ( InstalledPackage(..) ) hunk ./Distribution/Client/Haddock.hs 42 -regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackageInfo -> ProgramConfiguration -> FilePath -> IO () +regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () regenerateHaddockIndex verbosity pkgs conf index = do (paths,warns) <- haddockPackagePaths pkgs' case warns of hunk ./Distribution/Client/Haddock.hs 69 . allPackagesByName . fromList . filter exposed + . map (\(InstalledPackage pkg _) -> pkg) . allPackages $ pkgs hunk ./Distribution/Client/Haddock.hs 73 -haddockPackagePaths :: [InstalledPackageInfo_ m] +haddockPackagePaths :: [InstalledPackageInfo] -> IO ([(FilePath, FilePath)], Maybe [Char]) haddockPackagePaths pkgs = do interfaces <- sequence hunk ./Distribution/Client/Haddock.hs 84 then return (pkgid, Just (interface, html)) else return (pkgid, Nothing) Nothing -> return (pkgid, Nothing) - | pkg <- pkgs, let pkgid = InstalledPackageInfo.package pkg ] + | pkg <- pkgs, let pkgid = packageId pkg ] let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] hunk ./Distribution/Client/IndexUtils.hs 14 -- Extra utils related to the package indexes. ----------------------------------------------------------------------------- module Distribution.Client.IndexUtils ( + getInstalledPackages, getAvailablePackages, readPackageIndexFile, hunk ./Distribution/Client/IndexUtils.hs 28 import Distribution.Client.Types ( UnresolvedDependency(..), AvailablePackage(..) , AvailablePackageSource(..), Repo(..), RemoteRepo(..) - , AvailablePackageDb(..) ) + , AvailablePackageDb(..), InstalledPackage(..) ) import Distribution.Package ( PackageId, PackageIdentifier(..), PackageName(..), Package(..) hunk ./Distribution/Client/IndexUtils.hs 32 - , Dependency(Dependency) ) -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex + , Dependency(Dependency), InstalledPackageId(..) ) +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.PackageDescription ( GenericPackageDescription ) import Distribution.PackageDescription.Parse hunk ./Distribution/Client/IndexUtils.hs 41 ( parsePackageDescription ) +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import qualified Distribution.Simple.Configure as Configure + ( getInstalledPackages ) import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Version hunk ./Distribution/Client/IndexUtils.hs 50 - ( intersectVersionRanges ) + ( Version(Version), intersectVersionRanges ) import Distribution.Text ( display, simpleParse ) import Distribution.Verbosity (Verbosity) hunk ./Distribution/Client/IndexUtils.hs 75 import System.Time ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO (Maybe (PackageIndex InstalledPackage)) +getInstalledPackages verbosity comp packageDbs conf = + fmap (fmap convert) + (Configure.getInstalledPackages verbosity comp packageDbs conf) + where + convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage + convert index = PackageIndex.fromList $ + reverse -- because later ones mask earlier ones, but + -- InstalledPackageIndex.allPackages gives us the most preferred + -- instances first, when packages share a package id, like when + -- the same package is installed in the global & user dbs. + [ InstalledPackage ipkg (sourceDeps index ipkg) + | ipkg <- InstalledPackageIndex.allPackages index ] + + -- 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 + -- InstalledPackageId to get the InstalledPackageInfo and look at its + -- source PackageId. But if the package is broken because it depends on + -- other packages that do not exist then we have a problem we cannot find + -- the original source package id. Instead we make up a bogus package id. + -- This should have the same effect since it should be a dependency on a + -- non-existant package. + sourceDeps index ipkg = + [ maybe (brokenPackageId depid) packageId mdep + | let depids = InstalledPackageInfo.depends ipkg + getpkg = InstalledPackageIndex.lookupInstalledPackageId index + , (depid, mdep) <- zip depids (map getpkg depids) ] + + brokenPackageId (InstalledPackageId str) = + PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) + -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's. -- hunk ./Distribution/Client/Install.hs 47 import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) -- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies ) + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup hunk ./Distribution/Client/Install.hs 62 , AvailablePackageSource(..), AvailablePackageDb(..) , Repo(..), ConfiguredPackage(..) , BuildResult, BuildFailure(..), BuildSuccess(..) - , DocsResult(..), TestsResult(..), RemoteRepo(..) ) + , DocsResult(..), TestsResult(..), RemoteRepo(..) + , InstalledPackage ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.SetupWrapper hunk ./Distribution/Client/Install.hs 80 ( CompilerId(..), Compiler(compilerId), compilerFlavor , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) -import Distribution.Simple.Configure (getInstalledPackages) import qualified Distribution.Simple.InstallDirs as InstallDirs hunk ./Distribution/Client/Install.hs 81 -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..), emptyHaddockFlags , buildCommand, BuildFlags(..), emptyBuildFlags hunk ./Distribution/Client/Install.hs 105 ( readPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) import Distribution.Version ( Version, VersionRange, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils hunk ./Distribution/Client/Install.hs 162 | otherwise = planRepoPackages PreferAllLatest comp configFlags configExFlags installFlags deps -type Planner = Maybe (PackageIndex InstalledPackageInfo) +type Planner = Maybe (PackageIndex InstalledPackage) -> AvailablePackageDb -> IO (Progress String String InstallPlan) hunk ./Distribution/Client/Install.hs 462 ++ [ PackageVersionPreference name ver | Dependency name ver <- configPreferences configExFlags ] -printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackageInfo) +printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage) -> InstallPlan -> IO () printDryRun verbosity minstalled plan = case unfoldr next plan of [] -> return () hunk ./Distribution/Client/Install.hs 726 withWin32SelfUpgrade verbosity configFlags compid pkg action = do defaultDirs <- InstallDirs.defaultInstallDirs - compilerFlavor + compFlavor (fromFlag (configUserInstall configFlags)) (PackageDescription.hasLibs pkg) hunk ./Distribution/Client/Install.hs 735 where pkgid = packageId pkg - (CompilerId compilerFlavor _) = compid + (CompilerId compFlavor _) = compid exeInstallPaths defaultDirs = [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension hunk ./Distribution/Client/InstallPlan.hs 48 import Distribution.Client.Types ( AvailablePackage(packageDescription), ConfiguredPackage(..) + , InstalledPackage , BuildFailure, BuildSuccess ) import Distribution.Package ( PackageIdentifier(..), PackageName(..), Package(..), packageName hunk ./Distribution/Client/InstallPlan.hs 55 , PackageFixedDeps(..), Dependency(..) ) import Distribution.Version ( Version, withinRange ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) import Distribution.PackageDescription ( GenericPackageDescription(genPackageFlags) , PackageDescription(buildDepends) hunk ./Distribution/Client/InstallPlan.hs 61 , Flag(flagName), FlagName(..) ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) -import Distribution.Simple.PackageIndex +import Distribution.Client.PackageIndex ( PackageIndex ) hunk ./Distribution/Client/InstallPlan.hs 63 -import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Text ( display ) import Distribution.System hunk ./Distribution/Client/InstallPlan.hs 126 -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. -data PlanPackage = PreExisting InstalledPackageInfo +data PlanPackage = PreExisting InstalledPackage | Configured ConfiguredPackage | Installed ConfiguredPackage BuildSuccess | Failed ConfiguredPackage BuildFailure hunk ./Distribution/Client/List.hs 18 import Distribution.Package ( PackageName(..), packageName, packageVersion - , Dependency(..), thisPackageVersion ) + , Dependency(..), thisPackageVersion, depends ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) hunk ./Distribution/Client/List.hs 21 -import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.PackageDescription as Available import Distribution.PackageDescription hunk ./Distribution/Client/List.hs 28 import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.Simple.Configure (getInstalledPackages) import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration) hunk ./Distribution/Client/List.hs 33 import Distribution.Simple.Utils (equating, comparing, notice) import Distribution.Simple.Setup (fromFlag) -import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version (Version) import Distribution.Verbosity (Verbosity) import Distribution.Text hunk ./Distribution/Client/List.hs 41 import Distribution.Client.Types ( AvailablePackage(..), Repo, AvailablePackageDb(..) - , UnresolvedDependency(..) ) + , UnresolvedDependency(..), InstalledPackage(..) ) import Distribution.Client.Setup ( ListFlags(..), InfoFlags(..) ) import Distribution.Client.Utils hunk ./Distribution/Client/List.hs 47 ( mergeBy, MergeResult(..) ) import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies ) + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) import Distribution.Client.Fetch ( isFetched ) hunk ./Distribution/Client/List.hs 131 -- data PackageDisplayInfo = PackageDisplayInfo { pkgname :: PackageName, - allInstalled :: [InstalledPackageInfo], + allInstalled :: [InstalledPackage], allAvailable :: [AvailablePackage], hunk ./Distribution/Client/List.hs 133 - latestInstalled :: Maybe InstalledPackageInfo, + latestInstalled :: Maybe InstalledPackage, latestAvailable :: Maybe AvailablePackage, homepage :: String, bugReports :: String, hunk ./Distribution/Client/List.hs 273 -- the input package info records are all supposed to refer to the same -- package name. -- -mergePackageInfo :: [InstalledPackageInfo] +mergePackageInfo :: [InstalledPackage] -> [AvailablePackage] -> PackageDisplayInfo mergePackageInfo installedPkgs availablePkgs = hunk ./Distribution/Client/List.hs 316 (maybe [] Available.exposedModules . Available.library) available, dependencies = combine Available.buildDepends available - (map thisPackageVersion - . Installed.depends) installed, + (map thisPackageVersion . depends) installed', haddockHtml = fromMaybe "" . join . fmap (listToMaybe . Installed.haddockHTMLs) $ installed, hunk ./Distribution/Client/List.hs 324 } where combine f x g y = fromJust (fmap f x `mplus` fmap g y) - installed = latest installedPkgs + installed' = latest installedPkgs + installed = fmap (\(InstalledPackage p _) -> p) installed' availableGeneric = fmap packageDescription (latest availablePkgs) available = fmap flattenPackageDescription availableGeneric latest [] = Nothing hunk ./Distribution/Client/List.hs 352 -- same package by name. In the result pairs, the lists are guaranteed to not -- both be empty. -- -mergePackages :: [InstalledPackageInfo] -> [AvailablePackage] - -> [([InstalledPackageInfo], [AvailablePackage])] +mergePackages :: [InstalledPackage] -> [AvailablePackage] + -> [([InstalledPackage], [AvailablePackage])] mergePackages installed available = map collect $ mergeBy (\i a -> fst i `compare` fst a) addfile ./Distribution/Client/PackageIndex.hs hunk ./Distribution/Client/PackageIndex.hs 1 +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Client.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + ) where + +import Prelude hiding (lookup) +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Tree as Tree +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Data.Array ((!)) +import Data.List (groupBy, sortBy, nub, find, isInfixOf) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageIdentifier(..) + , Package(..), packageName, packageVersion + , Dependency(Dependency), PackageFixedDeps(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Simple.Utils (lowercase, equating, comparing) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched effeciently by package name and version. +-- +newtype Package pkg => PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Show, Read) + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex (Map.empty) + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = assert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + assert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg +deleteDependency (Dependency name verstionRange) = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: Package pkg => PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] +lookupDependency index (Dependency name versionRange) = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] +searchByName (PackageIndex m) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m + , lowercase name' == lname ] of + [] -> None + [(_,pkgs)] -> Unambiguous pkgs + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pkgs) -> Unambiguous pkgs + Nothing -> Ambiguous (map snd pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg] +searchByNameSubstring (PackageIndex m) searchterm = + [ pkg + | (PackageName name, pkgs) <- Map.toList m + , lsearchterm `isInfixOf` lowercase name + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + +-- +-- * Special queries +-- + +-- | All packages that have dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(pkg, [PackageIdentifier])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- depends pkg + , isNothing (lookupPackageId index pkg') ] + , not (null missing) ] + +-- | Tries to take the transative closure of the package dependencies. +-- +-- If the transative closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageIdentifier's do not occur in the index. +-- +dependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> Either (PackageIndex pkg) + [(pkg, [PackageIdentifier])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupPackageId completed (packageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = depends pkg ++ pkgids + +-- | Takes the transative closure of the packages reverse dependencies. +-- +-- * The given 'PackageIdentifier's must be in the index. +-- +reverseDependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> [pkg] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies index = + [ (name, inconsistencies) + | (name, uses) <- Map.toList inverseIndex + , let inconsistencies = duplicatesBy uses + versions = map snd inconsistencies + , reallyIsInconsistent name (nub versions) ] + + where inverseIndex = Map.fromListWith (++) + [ (packageName dep, [(packageId pkg, packageVersion dep)]) + | pkg <- allPackages index + , dep <- depends pkg ] + + duplicatesBy = (\groups -> if length groups == 1 + then [] + else concat groups) + . groupBy (equating snd) + . sortBy (comparing snd) + + reallyIsInconsistent :: PackageName -> [Version] -> Bool + reallyIsInconsistent _ [] = False + reallyIsInconsistent name [v1, v2] = + case (mpkg1, mpkg2) of + (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 + && pkgid2 `notElem` depends pkg1 + _ -> True + where + pkgid1 = PackageIdentifier name v1 + pkgid2 = PackageIdentifier name v2 + mpkg1 = lookupPackageId index pkgid1 + mpkg2 = lookupPackageId index pkgid2 + + reallyIsInconsistent _ _ = True + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageFixedDeps pkg + => PackageIndex pkg + -> [[pkg]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, packageId pkg, depends pkg) + | pkg <- allPackages index ] + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageFixedDeps pkg + => PackageIndex pkg + -> (Graph.Graph, + Graph.Vertex -> pkg, + PackageIdentifier -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] + | pkg <- pkgs ] + vertexToPkg vertex = pkgTable ! vertex + pkgIdToVertex = binarySearch 0 topBound + + pkgTable = Array.listArray bounds pkgs + pkgIdTable = Array.listArray bounds (map packageId pkgs) + pkgs = sortBy (comparing packageId) (allPackages index) + topBound = length pkgs - 1 + bounds = (0, topBound) + + binarySearch a b key + | a > b = Nothing + | otherwise = case compare key (pkgIdTable ! mid) of + LT -> binarySearch a (mid-1) key + EQ -> Just mid + GT -> binarySearch (mid+1) b key + where mid = (a + b) `div` 2 hunk ./Distribution/Client/SetupWrapper.hs 23 defaultSetupScriptOptions, ) where +import Distribution.Client.Types + ( InstalledPackage ) + import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version hunk ./Distribution/Client/SetupWrapper.hs 39 , PackageDescription(..), BuildType(..) ) import Distribution.PackageDescription.Parse ( readPackageDescription ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) import Distribution.Simple.Configure hunk ./Distribution/Client/SetupWrapper.hs 40 - ( configCompiler, getInstalledPackages ) + ( configCompiler ) import Distribution.Simple.Compiler ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) import Distribution.Simple.Program hunk ./Distribution/Client/SetupWrapper.hs 52 ( CommandUI(..), commandShowOptions ) import Distribution.Simple.GHC ( ghcVerbosityOptions ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.IndexUtils + ( getInstalledPackages ) import Distribution.Simple.Utils ( die, debug, info, cabalVersion, findPackageDesc, comparing , createDirectoryIfMissingVerbose ) hunk ./Distribution/Client/SetupWrapper.hs 81 useCabalVersion :: VersionRange, useCompiler :: Maybe Compiler, usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe (PackageIndex InstalledPackageInfo), + usePackageIndex :: Maybe (PackageIndex InstalledPackage), useProgramConfig :: ProgramConfiguration, useDistPref :: FilePath, useLoggingHandle :: Maybe Handle, hunk ./Distribution/Client/Types.hs 16 module Distribution.Client.Types where import Distribution.Package - ( PackageName, PackageIdentifier(..), Package(..) + ( PackageName, PackageId, Package(..) , PackageFixedDeps(..), Dependency ) hunk ./Distribution/Client/Types.hs 18 +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) import Distribution.PackageDescription ( GenericPackageDescription, FlagAssignment ) hunk ./Distribution/Client/Types.hs 22 -import Distribution.Simple.PackageIndex +import Distribution.Client.PackageIndex ( PackageIndex ) import Distribution.Version ( VersionRange ) hunk ./Distribution/Client/Types.hs 42 packagePreferences :: Map PackageName VersionRange } +-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. +-- What is new in 1.8 is that installed packages and dependencies between +-- installed packages are now identified by an opaque InstalledPackageId +-- rather than a source PackageId. +-- +-- We should use simply an 'InstalledPackageInfo' here but to ease the +-- transition we are temporarily using this variant where we pretend that +-- installed packages still specify their deps in terms of PackageIds. +-- +-- Crucially this means that 'InstalledPackage' can be an instance of +-- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance +-- of that class. This means we can make 'PackageIndex'es of InstalledPackage +-- where as the InstalledPackageInfo now has its own monomorphic index type. +-- +data InstalledPackage = InstalledPackage + InstalledPackageInfo + [PackageId] + +instance Package InstalledPackage where + packageId (InstalledPackage pkg _) = packageId pkg +instance PackageFixedDeps InstalledPackage where + depends (InstalledPackage _ deps) = deps + -- | A 'ConfiguredPackage' is a not-yet-installed package along with the -- total configuration information. The configuration information is total in -- the sense that it provides all the configuration information and so the hunk ./Distribution/Client/Types.hs 73 data ConfiguredPackage = ConfiguredPackage AvailablePackage -- package info, including repo FlagAssignment -- complete flag assignment for the package - [PackageIdentifier] -- set of exact dependencies. These must be + [PackageId] -- set of exact dependencies. These must be -- consistent with the 'buildDepends' in the -- 'PackageDescrption' that you'd get by applying -- the flag assignment. hunk ./Distribution/Client/Types.hs 89 -- | We re-use @GenericPackageDescription@ and use the @package-url@ -- field to store the tarball URI. data AvailablePackage = AvailablePackage { - packageInfoId :: PackageIdentifier, + packageInfoId :: PackageId, packageDescription :: GenericPackageDescription, packageSource :: AvailablePackageSource } hunk ./Distribution/Client/Types.hs 139 deriving (Show) type BuildResult = Either BuildFailure BuildSuccess -data BuildFailure = DependentFailed PackageIdentifier +data BuildFailure = DependentFailed PackageId | DownloadFailed Exception | UnpackFailed Exception | ConfigureFailed Exception hunk ./Distribution/Client/Unpack.hs 21 ) where import Distribution.Package ( packageId, Dependency(..) ) -import Distribution.Simple.PackageIndex as PackageIndex (lookupDependency) +import Distribution.Client.PackageIndex as PackageIndex (lookupDependency) import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault) import Distribution.Simple.Utils(info, notice, die) import Distribution.Text(display) hunk ./Distribution/Client/Update.hs 23 ( downloadIndex ) import qualified Distribution.Client.Utils as BS ( writeFileAtomic ) -import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.IndexUtils ( getAvailablePackages ) import qualified Paths_cabal_install hunk ./cabal-install.cabal 78 Paths_cabal_install build-depends: base >= 2 && < 4, - Cabal >= 1.7.3 && < 1.9, + Cabal >= 1.7.5 && < 1.9, filepath >= 1.0, network >= 1 && < 3, HTTP >= 4000.0.2 && < 4001, } Context: [Apply suggestion for bootstrap failure message Duncan Coutts **20091020212319 Ignore-this: 70ed13514b158db7672f5d16a9ed90ea ghc ticket #3602 ] [Fix calculation of paths in check for bindir symlink overwriting Duncan Coutts **20090829004959 Ignore-this: d4dd8e12c03d23ce935de94cedbda257 We were doing it wrong, but Linux realpath() C function was letting us get away with it. The Solaris realpath() is stricter. The new implementation is also simpler, relying on the fact that the canonicalizePath function will resolve symlinks. ] [Require Cabal lib version 1.7.3 Duncan Coutts **20090707095944 Needs recent api changes. ] [Make the documentation toggle determine if we make the haddock index Duncan Coutts **20090707013030 Previously the --haddock-index=template flag controled both the template used and whether it's used at all. When no path was set then it was not used. The problem with that is that since we are not enabling this feature by default then the default is blank. That is the default config file would look like: -- haddock-index: which doesn't help anyone discover what it means or what a sensible setting would be. By having a separate toggle to enable/disable we can have a default for the index file which makes it easy to discover in the config file: -- documentation: False -- doc-index-file: $datadir/doc/index.html All the user has to do is uncomment the first line and use True. ] [Be less noisy about warning about packages with missing docs Duncan Coutts **20090707005149] [Use defaultInstallFlags as the defaults Duncan Coutts **20090707004836] [Move regenerateHaddockIndex more out-of-line in the Install module Duncan Coutts **20090707003722 Also update the code somewhat following the changes in the Cabal API for path templates and substitutions. ] [Use $pkgroot/package/$pkgid.tar.gz as tarball URL Duncan Coutts **20090704170602] [#516, maintains a per-user index of haddock docs Andrea Vezzosi **20090607170512 Ignore-this: 1114f6b944043781c4bf99620573b1cc If the haddock-index flag is set it keeps an index of the haddock documentation of the packages in the global and user databases ] [Now supporting explicit --user or --global switches in bootstrap.sh with usage feedback for bad args Dino Morelli **20090613150958 Ignore-this: 490a4fcdd5bc1940d6f32d71b0a042a5 This change was adapted from work submitted to the cabal-devel mailing list by Jason Dusek. ] [add message to 'package not found' error advising to run 'cabal update'. (#497) Brent Yorgey **20090611171233] [Fix sdist Duncan Coutts **20090605023441 Fix handling of base dir in tar file creation. ] [Fix use of deprecated version constructors Duncan Coutts **20090604180500] [Only report preferred new versions of cabal-install are available Duncan Coutts **20090604175726 That is, use the "preferred-versions" mechanism when deciding whether there is a new version available. This would allow us to upload a new version without everyone immediately being told to get it and try it out. ] [Make cabal upload/check print out the error messages reported by the server Duncan Coutts **20090604124836 The code to do it was already there but we were checking for the mime type text/plain using just (==) when in fact the server reports text/plain; charset="ISO-8859-1" so we have to parse the field a bit better (still a bit of a hack). ] [Require latest Cabal lib version Duncan Coutts **20090603102312] [Improve formatting of cabal check output Duncan Coutts **20090603102254] [Only apply preferences to base if its version is unbounded above Duncan Coutts **20090603101623 Fixes ticket #485. This means that for constraints like: build-depends: base >= 3 && < 5 we will pick version 4. However we will continue to apply the version 3 preference for things like: build-depends: base >= 3 Where there is no upper bound on the version. Note that we now also ignore preferences for base given on the command line. We should implement #483 to split prefs from shims. ] [Improve the parse error message for package name/deps Duncan Coutts **20090321154623 Make it clear that it's the specification of the package name that is at fault rather than the package to which the name refers. ] [Debian in their wisdom decided to build network against parsec 3. Duncan Coutts **20090308142925 So checking for parsec 2 fails. We don't strictly need parsec, it's just a dependency of network, so remove the check. ] [Simplify version ranges before printing in error messages Duncan Coutts **20090531191346 Part of ticket #369 ] [Use new top handler, should get better error messages Duncan Coutts **20090531190318] [Fix uses of deprecated stuff Duncan Coutts **20090531190239] [New development branch, version 0.7 Duncan Coutts **20090531184336 Update to development version of Cabal ] [Solaris 9 /bin/sh doesn't like the ! syntax in bootstrap.sh Duncan Coutts **20090318091730] [Clarify the instructions in the README and bootstrap.sh Duncan Coutts **20090315125407 Addresses the complaint in ticket #523. ] [Select Configuration file via env var CABAL_CONFIG. Paolo Losi **20090223005251 Ignore-this: 26e5ded85cb69cb3a19cd57680a8a362 ] [Update tar code based on new tar package Duncan Coutts **20090301174949] [Actually does compile with unix-1.0 that comes with ghc-6.6 Duncan Coutts **20090221154605 ghc-6.6.1 came with unix-2.1 ] [TAG 0.6.2 Duncan Coutts **20090219130720] Patch bundle hash: 57fbcfb83c9d82d3f84d1f11296b6141cfc15221