diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs --- a/Distribution/Client/BuildReports/Anonymous.hs +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -23,7 +23,7 @@ parse, parseList, show, - showList, +-- showList, ) where import Distribution.Client.Types @@ -36,7 +36,7 @@ import qualified Paths_cabal_install (version) import Distribution.Package - ( PackageIdentifier(PackageIdentifier), Package(packageId) ) + ( PackageIdentifier(..), PackageName(..), Package(packageId) ) import Distribution.PackageDescription ( FlagName(..), FlagAssignment ) --import Distribution.Version @@ -114,8 +114,10 @@ | BuildFailed | InstallFailed | InstallOk + deriving Eq data Outcome = NotTried | Failed | Ok + deriving Eq new :: OS -> Arch -> CompilerId -- -> Version -> ConfiguredPackage -> BR.BuildResult @@ -135,11 +137,9 @@ testsOutcome = convertTestsOutcome } where - cabalInstallID = - PackageIdentifier "cabal-install" Paths_cabal_install.version - convertInstallOutcome = case result of Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed Left (BR.UnpackFailed _) -> UnpackFailed Left (BR.ConfigureFailed _) -> ConfigureFailed Left (BR.BuildFailed _) -> BuildFailed @@ -156,6 +156,10 @@ Right (BR.BuildOk _ BR.TestsFailed) -> Failed Right (BR.BuildOk _ BR.TestsOk) -> Ok +cabalInstallID :: PackageIdentifier +cabalInstallID = + PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version + -- ------------------------------------------------------------ -- * External format -- ------------------------------------------------------------ @@ -226,7 +230,7 @@ -- Pretty-printing show :: BuildReport -> String -show br = Disp.render (ppFields br fieldDescrs) +show = Disp.render . ppFields fieldDescrs -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -17,11 +17,15 @@ import Control.Monad ( when, unless ) -import Distribution.PackageDescription ( readPackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) import Distribution.PackageDescription.Check -import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.Verbosity ( Verbosity ) -import Distribution.Simple.Utils ( defaultPackageDesc, toUTF8 ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( defaultPackageDesc, toUTF8 ) check :: Verbosity -> IO Bool check verbosity = do diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -15,7 +15,12 @@ module Distribution.Client.Dependency ( resolveDependencies, resolveDependenciesWithProgress, - PackagesVersionPreference(..), + + PackagesPreference(..), + packagesPreference, + PackagesVersionPreference, + PackagesInstalledPreference(..), + upgradableDependencies, ) where @@ -29,13 +34,14 @@ import Distribution.Client.Types ( UnresolvedDependency(..), AvailablePackage(..) ) import Distribution.Client.Dependency.Types - ( PackageName, DependencyResolver, PackageVersionPreference(..) + ( PackageName, DependencyResolver + , PackagePreference(..), PackageInstalledPreference(..) , Progress(..), foldProgress ) import Distribution.Package - ( PackageIdentifier(..), packageVersion, packageName + ( PackageIdentifier(..), PackageName(..), packageVersion, packageName , Dependency(..), Package(..), PackageFixedDeps(..) ) import Distribution.Version - ( orLaterVersion ) + ( VersionRange(AnyVersion), orLaterVersion ) import Distribution.Compiler ( CompilerId ) import Distribution.System @@ -45,18 +51,41 @@ import Data.List (maximumBy) import Data.Monoid (Monoid(mempty)) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map +import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) import Control.Exception (assert) defaultResolver :: DependencyResolver defaultResolver = topDownResolver ---for the brave: try the new topDownResolver, but only with --dry-run !!! -- | Global policy for the versions of all packages. -- -data PackagesVersionPreference = +data PackagesPreference = PackagesPreference + PackagesInstalledPreference + PackagesVersionPreference +packagesPreference :: PackagesInstalledPreference + -> Map PackageName VersionRange + -> PackagesPreference +packagesPreference installedPref versionPrefs = + PackagesPreference installedPref versionPrefs' + where + versionPrefs' :: PackageName -> VersionRange + versionPrefs' pkgname = + fromMaybe AnyVersion (Map.lookup pkgname versionPrefs) + +-- | An optional suggested version for each package. +-- +type PackagesVersionPreference = PackageName -> VersionRange + +-- | 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 PackagesInstalledPreference = + -- | Always prefer the latest version irrespective of any existing -- installed version. -- @@ -81,7 +110,7 @@ -> CompilerId -> Maybe (PackageIndex InstalledPackageInfo) -> PackageIndex AvailablePackage - -> PackagesVersionPreference + -> PackagesPreference -> [UnresolvedDependency] -> Either String InstallPlan resolveDependencies os arch comp installed available pref deps = @@ -93,7 +122,7 @@ -> CompilerId -> Maybe (PackageIndex InstalledPackageInfo) -> PackageIndex AvailablePackage - -> PackagesVersionPreference + -> PackagesPreference -> [UnresolvedDependency] -> Progress String String InstallPlan resolveDependenciesWithProgress os arch comp (Just installed) = @@ -113,15 +142,15 @@ check p x = assert (p x) x hideBasePackage :: Package p => PackageIndex p -> PackageIndex p -hideBasePackage = PackageIndex.deletePackageName "base" - . PackageIndex.deletePackageName "ghc-prim" +hideBasePackage = PackageIndex.deletePackageName (PackageName "base") + . PackageIndex.deletePackageName (PackageName "ghc-prim") dependencyResolver :: DependencyResolver -> OS -> Arch -> CompilerId -> PackageIndex InstalledPackageInfo -> PackageIndex AvailablePackage - -> PackagesVersionPreference + -> PackagesPreference -> [UnresolvedDependency] -> Progress String String InstallPlan dependencyResolver resolver os arch comp installed available pref deps = @@ -139,25 +168,26 @@ : "The proposed (invalid) plan contained the following problems:" : map InstallPlan.showPlanProblem problems - preference = interpretPackagesVersionPreference initialPkgNames pref + preference = interpretPackagesPreference initialPkgNames pref initialPkgNames = Set.fromList [ name | UnresolvedDependency (Dependency name _) _ <- deps ] --- | Give an interpretation to the global 'PackagesVersionPreference' as +-- | Give an interpretation to the global 'PackagesPreference' as -- specific per-package 'PackageVersionPreference'. -- -interpretPackagesVersionPreference :: Set PackageName - -> PackagesVersionPreference - -> (PackageName -> PackageVersionPreference) -interpretPackagesVersionPreference selected pref = case pref of - PreferAllLatest -> const PreferLatest - PreferAllInstalled -> const PreferInstalled - PreferLatestForSelected -> \pkgname -> - -- When you say cabal install foo, what you really mean is, prefer the - -- latest version of foo, but the installed version of everything else: - if pkgname `Set.member` selected - then PreferLatest - else PreferInstalled +interpretPackagesPreference :: Set PackageName + -> PackagesPreference + -> (PackageName -> PackagePreference) +interpretPackagesPreference selected + (PackagesPreference installPref versionPref) = case installPref of + PreferAllLatest -> PackagePreference PreferLatest . versionPref + PreferAllInstalled -> PackagePreference PreferInstalled . versionPref + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else: + if pkgname `Set.member` selected + then PackagePreference PreferLatest (versionPref pkgname) + else PackagePreference PreferInstalled (versionPref pkgname) -- | Given the list of installed packages and available packages, figure -- out which packages can be upgraded. diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs --- a/Distribution/Client/Dependency/TopDown.hs +++ b/Distribution/Client/Dependency/TopDown.hs @@ -25,7 +25,8 @@ ( UnresolvedDependency(..), AvailablePackage(..) , ConfiguredPackage(..) ) import Distribution.Client.Dependency.Types - ( PackageName, DependencyResolver, PackageVersionPreference(..) + ( PackageName, DependencyResolver, PackagePreference(..) + , PackageInstalledPreference(..) , Progress(..), foldProgress ) import qualified Distribution.Simple.PackageIndex as PackageIndex @@ -33,13 +34,15 @@ import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Package - ( PackageIdentifier, Package(packageId), packageVersion, packageName + ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName , Dependency(Dependency), thisPackageVersion, notThisPackageVersion , PackageFixedDeps(depends) ) import Distribution.PackageDescription ( PackageDescription(buildDepends) ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription, flattenPackageDescription ) +import Distribution.Version + ( withinRange ) import Distribution.Compiler ( CompilerId ) import Distribution.System @@ -50,7 +53,7 @@ ( display ) import Data.List - ( foldl', maximumBy, minimumBy, deleteBy, nub, sort ) + ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) import Data.Maybe ( fromJust, fromMaybe ) import Data.Monoid @@ -83,35 +86,44 @@ -- * Traverse a search tree -- ------------------------------------------------------------ -explore :: (PackageName -> PackageVersionPreference) - -> SearchSpace a SelectablePackage - -> Progress Log Failure a +explore :: (PackageName -> PackagePreference) + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage + -> Progress Log Failure (SelectedPackages, Constraints) -explore _ (Failure failure) = Fail failure -explore _explore (ChoiceNode result []) = Done result -explore pref (ChoiceNode _ choices) = +explore _ (Failure failure) = Fail failure +explore _ (ChoiceNode (s,c,_) []) = Done (s,c) +explore pref (ChoiceNode _ choices) = case [ choice | [choice] <- choices ] of - ((pkg, node'):_) -> Step (Select pkg []) (explore pref node') - [] -> seq pkgs' -- avoid retaining defaultChoice - $ Step (Select pkg pkgs') (explore pref node') + ((_, node'):_) -> Step (logInfo node') (explore pref node') + [] -> Step (logInfo node') (explore pref node') where - choice = minimumBy (comparing topSortNumber) choices - pkgname = packageName . fst . head $ choice - (pkg, node') = maximumBy (bestByPref pkgname) choice - pkgs' = deleteBy (equating packageId) pkg (map fst choice) - + choice = minimumBy (comparing topSortNumber) choices + pkgname = packageName . fst . head $ choice + (_, node') = maximumBy (bestByPref pkgname) choice where topSortNumber choice = case fst (head choice) of InstalledOnly (InstalledPackage _ i _) -> i AvailableOnly (UnconfiguredPackage _ i _) -> i InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i - bestByPref pkgname = case pref pkgname of - PreferLatest -> comparing (\(p,_) -> packageId p) - PreferInstalled -> comparing (\(p,_) -> (isInstalled p, packageId p)) - where isInstalled (AvailableOnly _) = False - isInstalled _ = True + bestByPref pkgname = case packageInstalledPreference of + PreferLatest -> + comparing (\(p,_) -> ( isPreferred p, packageId p)) + PreferInstalled -> + comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) + where + isInstalled (AvailableOnly _) = False + isInstalled _ = True + isPreferred p = packageVersion p `withinRange` preferredVersions + (PackagePreference packageInstalledPreference preferredVersions) + = pref pkgname + logInfo node = Select selected discarded + where (selected, discarded) = case node of + Failure _ -> ([], []) + ChoiceNode (_,_,changes) _ -> changes + -- ------------------------------------------------------------ -- * Generate a search tree -- ------------------------------------------------------------ @@ -120,13 +132,18 @@ -> SelectablePackage -> Either [Dependency] SelectedPackage +-- | (packages selected, packages discarded) +type SelectionChanges = ([SelectedPackage], [PackageIdentifier]) + searchSpace :: ConfigurePackage -> Constraints -> SelectedPackages + -> SelectionChanges -> Set PackageName - -> SearchSpace (SelectedPackages, Constraints) SelectablePackage -searchSpace configure constraints selected next = - ChoiceNode (selected, constraints) + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage +searchSpace configure constraints selected changes next = + ChoiceNode (selected, constraints, changes) [ [ (pkg, select name pkg) | pkg <- PackageIndex.lookupPackageName available name ] | name <- Set.elems next ] @@ -137,20 +154,29 @@ Left missing -> Failure $ ConfigureFailed pkg [ (dep, Constraints.conflicting constraints dep) | dep <- missing ] - Right pkg' -> - let selected' = PackageIndex.insert pkg' selected - newPkgs = [ name' - | dep <- packageConstraints pkg' - , let (Dependency name' _) = untagDependency dep - , null (PackageIndex.lookupPackageName selected' name') ] - newDeps = packageConstraints pkg' - next' = Set.delete name - $ foldl' (flip Set.insert) next newPkgs - in case constrainDeps pkg' newDeps constraints of - Left failure -> Failure failure - Right constraints' -> searchSpace configure - constraints' selected' next' + Right pkg' -> case constrainDeps pkg' newDeps constraints [] of + Left failure -> Failure failure + Right (constraints', newDiscarded) -> + searchSpace configure + constraints' selected' (newSelected, newDiscarded) next' + where + selected' = foldl' (flip PackageIndex.insert) selected newSelected + newSelected = + case Constraints.isPaired constraints (packageId pkg) of + Nothing -> [pkg'] + Just pkgid' -> [pkg', pkg''] + where + Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) + (PackageIndex.lookupPackageId available pkgid') + newPkgs = [ name' + | dep <- newDeps + , let (Dependency name' _) = untagDependency dep + , null (PackageIndex.lookupPackageName selected' name') ] + newDeps = concatMap packageConstraints newSelected + next' = Set.delete name + $ foldl' (flip Set.insert) next newPkgs + packageConstraints :: SelectedPackage -> [TaggedDependency] packageConstraints = either installedConstraints availableConstraints . preferAvailable @@ -165,16 +191,17 @@ [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints - -> Either Failure Constraints -constrainDeps pkg [] cs = + -> [PackageIdentifier] + -> Either Failure (Constraints, [PackageIdentifier]) +constrainDeps pkg [] cs discard = case addPackageSelectConstraint (packageId pkg) cs of - Satisfiable cs' -> Right cs' - _ -> impossible -constrainDeps pkg (dep:deps) cs = + Satisfiable cs' discard' -> Right (cs', discard' ++ discard) + _ -> impossible +constrainDeps pkg (dep:deps) cs discard = case addPackageDependencyConstraint (packageId pkg) dep cs of - Satisfiable cs' -> constrainDeps pkg deps cs' - Unsatisfiable -> impossible - ConflictsWith conflicts -> + Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) + Unsatisfiable -> impossible + ConflictsWith conflicts -> Left (DependencyConflict pkg dep conflicts) -- ------------------------------------------------------------ @@ -182,12 +209,12 @@ -- ------------------------------------------------------------ search :: ConfigurePackage - -> (PackageName -> PackageVersionPreference) + -> (PackageName -> PackagePreference) -> Constraints -> Set PackageName -> Progress Log Failure (SelectedPackages, Constraints) search configure pref constraints = - explore pref . searchSpace configure constraints mempty + explore pref . searchSpace configure constraints mempty ([], []) -- ------------------------------------------------------------ -- * The top level resolver @@ -207,7 +234,7 @@ topDownResolver' :: OS -> Arch -> CompilerId -> PackageIndex InstalledPackageInfo -> PackageIndex AvailablePackage - -> (PackageName -> PackageVersionPreference) + -> (PackageName -> PackagePreference) -> [UnresolvedDependency] -> Progress Log Failure [PlanPackage] topDownResolver' os arch comp installed available pref deps = @@ -230,14 +257,14 @@ finalise selected = PackageIndex.allPackages . improvePlan installed' . PackageIndex.fromList - . finaliseSelectedPackages selected + . finaliseSelectedPackages pref selected constrainTopLevelDeps :: [UnresolvedDependency] -> Constraints -> Progress a Failure Constraints constrainTopLevelDeps [] cs = Done cs constrainTopLevelDeps (UnresolvedDependency dep _:deps) cs = case addTopLevelDependencyConstraint dep cs of - Satisfiable cs' -> constrainTopLevelDeps deps cs' + Satisfiable cs' _ -> constrainTopLevelDeps deps cs' Unsatisfiable -> Fail (TopLevelDependencyUnsatisfiable dep) ConflictsWith conflicts -> Fail (TopLevelDependencyConflict dep conflicts) @@ -265,9 +292,9 @@ | pkg <- PackageIndex.allPackages installed ] where transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier] - transitiveDepends = map toPkgid . tail . Graph.reachable graph + transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph . fromJust . toVertex . packageId - (graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed + (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed -- | Annotate each available packages with its topological sort number and any @@ -352,7 +379,10 @@ (next, remaining') = Set.deleteFindMin remaining moreInstalled = PackageIndex.lookupPackageName installed next moreAvailable = PackageIndex.lookupPackageName available next - moreRemaining = nub + 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 + filter notAlreadyIncluded $ [ packageName dep | pkg <- moreInstalled , dep <- depends pkg ] @@ -360,38 +390,57 @@ | AvailablePackage _ pkg _ <- moreAvailable , Dependency name _ <- buildDepends (flattenPackageDescription pkg) ] - installed'' = foldr PackageIndex.insert installed' moreInstalled - available'' = foldr PackageIndex.insert available' moreAvailable - remaining'' = foldr Set.insert remaining' moreRemaining + 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) -- ------------------------------------------------------------ -- * Post processing the solution -- ------------------------------------------------------------ -finaliseSelectedPackages :: SelectedPackages +finaliseSelectedPackages :: (PackageName -> PackagePreference) + -> SelectedPackages -> Constraints -> [PlanPackage] -finaliseSelectedPackages selected constraints = +finaliseSelectedPackages pref selected constraints = map finaliseSelected (PackageIndex.allPackages selected) where remainingChoices = Constraints.choices constraints finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg - finaliseSelected (AvailableOnly apkg) = finaliseAvailable apkg + finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing apkg finaliseSelected (InstalledAndAvailable 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 apkg + Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg finaliseInstalled (InstalledPackage pkg _ _) = InstallPlan.PreExisting pkg - finaliseAvailable (SemiConfiguredPackage pkg flags deps) = + finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = InstallPlan.Configured (ConfiguredPackage pkg flags deps') - where deps' = [ packageId pkg' - | dep <- deps - , let pkg' = case PackageIndex.lookupDependency selected dep of - [pkg''] -> pkg'' - _ -> impossible ] + where + deps' = map (packageId . pickRemaining) deps + pickRemaining dep = + case PackageIndex.lookupDependency remainingChoices dep of + [] -> impossible + [pkg'] -> pkg' + remaining -> maximumBy bestByPref remaining + -- We order candidate packages to pick for a dependency by these + -- three factors. The last factor is just highest version wins. + bestByPref = + comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) + -- 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 + Nothing -> \_ -> False + Just ipkg -> \p -> packageId p `elem` depends ipkg + -- Is this package a preferred version acording to the hackage or + -- user's suggested version constraints + isPreferred p = packageVersion p `withinRange` preferredVersions + where (PackagePreference _ preferredVersions) = pref (packageName p) -- | Improve an existing installation plan by, where possible, swapping -- packages we plan to install with ones that are already installed. @@ -424,18 +473,19 @@ reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [PackageIdentifier] - reverseTopologicalOrder index = map toPkgId + reverseTopologicalOrder index = map (packageId . toPkg) . Graph.topSort . Graph.transposeG $ graph - where (graph, toPkgId, _) = PackageIndex.dependencyGraph index + where (graph, toPkg, _) = PackageIndex.dependencyGraph index -- ------------------------------------------------------------ -- * Adding and recording constraints -- ------------------------------------------------------------ addPackageSelectConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints ExclusionReason + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason addPackageSelectConstraint pkgid constraints = Constraints.constrain dep reason constraints where @@ -443,7 +493,8 @@ reason = SelectedOther pkgid addPackageExcludeConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints ExclusionReason + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason addPackageExcludeConstraint pkgid constraints = Constraints.constrain dep reason constraints where @@ -452,14 +503,16 @@ reason = ExcludedByConfigureFail addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints - -> Satisfiable Constraints ExclusionReason + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason addPackageDependencyConstraint pkgid dep constraints = Constraints.constrain dep reason constraints where reason = ExcludedByPackageDependency pkgid dep addTopLevelDependencyConstraint :: Dependency -> Constraints - -> Satisfiable Constraints ExclusionReason + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason addTopLevelDependencyConstraint dep constraints = Constraints.constrain taggedDep reason constraints where @@ -514,7 +567,7 @@ -- * Logging progress and failures -- ------------------------------------------------------------ -data Log = Select SelectablePackage [SelectablePackage] +data Log = Select [SelectedPackage] [PackageIdentifier] data Failure = ConfigureFailed SelectablePackage @@ -529,18 +582,31 @@ Dependency showLog :: Log -> String -showLog (Select selected discarded) = - "selecting " ++ displayPkg selected ++ " " ++ kind selected - ++ case discarded of - [] -> "" - [d] -> " and discarding version " ++ display (packageVersion d) - _ -> " and discarding versions " - ++ listOf (display . packageVersion) discarded +showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of + ("", y) -> y + (x, "") -> x + (x, y) -> x ++ " and " ++ y + where + selectedMsg = "selecting " ++ case selected of + [] -> "" + [s] -> display (packageId s) ++ " " ++ kind s + (s:ss) -> listOf id + $ (display (packageId s) ++ " " ++ kind s) + : [ display (packageVersion s') ++ " " ++ kind s' + | s' <- ss ] + kind (InstalledOnly _) = "(installed)" kind (AvailableOnly _) = "(hackage)" kind (InstalledAndAvailable _ _) = "(installed or hackage)" + discardedMsg = case discarded of + [] -> "" + _ -> "discarding " ++ listOf id + [ element + | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) + , element <- display pkgid : map (display . packageVersion) pkgids ] + showFailure :: Failure -> String showFailure (ConfigureFailed pkg missingDeps) = "cannot configure " ++ displayPkg pkg ++ ". It requires " @@ -549,7 +615,7 @@ where whyNot (Dependency name ver) [] = - "There is no available version of " ++ name + "There is no available version of " ++ display name ++ " that satisfies " ++ display ver whyNot dep conflicts = @@ -574,7 +640,7 @@ | (pkg', reasons) <- conflicts, reason <- reasons ] showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) = - "There is no available version of " ++ name + "There is no available version of " ++ display name ++ " that satisfies " ++ display ver -- ------------------------------------------------------------ diff --git a/Distribution/Client/Dependency/TopDown/Constraints.hs b/Distribution/Client/Dependency/TopDown/Constraints.hs --- a/Distribution/Client/Dependency/TopDown/Constraints.hs +++ b/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -14,6 +14,7 @@ Constraints, empty, choices, + isPaired, constrain, Satisfiable(..), @@ -24,19 +25,23 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Package - ( PackageIdentifier, Package(packageId), packageVersion, packageName + ( PackageName, PackageIdentifier(..) + , Package(packageId), packageName, packageVersion + , PackageFixedDeps(depends) , Dependency(Dependency) ) import Distribution.Version - ( withinRange ) -import Distribution.Simple.Utils - ( comparing ) + ( Version, withinRange ) import Distribution.Client.Utils ( mergeBy, MergeResult(..) ) import Data.List - ( foldl', sortBy ) + ( foldl' ) import Data.Monoid ( Monoid(mempty) ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Data.Map (Map) import Control.Exception ( assert ) @@ -51,6 +56,9 @@ -- Remaining available choices (PackageIndex (InstalledOrAvailable installed available)) + -- Paired choices + (Map PackageName (Version, Version)) + -- Choices that we have excluded for some reason -- usually by applying constraints (PackageIndex (ExcludedPackage PackageIdentifier reason)) @@ -65,7 +73,7 @@ -- | The intersection between the two indexes is empty invariant :: (Package installed, Package available) => Constraints installed available a -> Bool -invariant (Constraints available excluded) = +invariant (Constraints available _ excluded) = all (uncurry ok) [ (a, e) | InBoth a e <- merged ] where merged = mergeBy (\a b -> packageId a `compare` packageId b) @@ -79,8 +87,8 @@ transitionsTo :: (Package installed, Package available) => Constraints installed available a -> Constraints installed available a -> Bool -transitionsTo constraints @(Constraints available excluded ) - constraints'@(Constraints available' excluded') = +transitionsTo constraints @(Constraints available _ excluded ) + constraints'@(Constraints available' _ excluded') = invariant constraints && invariant constraints' && null availableGained && null excludedLost && map packageId availableLost == map packageId excludedGained @@ -95,48 +103,59 @@ excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ] excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ] availableChange = mergeBy (\a b -> packageId a `compare` packageId b) - (allPackagesInOrder available) - (allPackagesInOrder available') + (PackageIndex.allPackages available) + (PackageIndex.allPackages available') excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) - (allPackagesInOrder excluded) - (allPackagesInOrder excluded') - ---FIXME: PackageIndex.allPackages returns in sorted order case-insensitively --- but that's no good for our merge which uses Ord -allPackagesInOrder :: Package pkg => PackageIndex pkg -> [pkg] -allPackagesInOrder index = - concatMap snd - . sortBy (comparing fst) - $ [ (packageName pkg, grp) - | grp@(pkg:_) <- PackageIndex.allPackagesByName index ] + (PackageIndex.allPackages excluded) + (PackageIndex.allPackages excluded') -- | We construct 'Constraints' with an initial 'PackageIndex' of all the -- packages available. -- -empty :: (Package installed, Package available) +empty :: (PackageFixedDeps installed, Package available) => PackageIndex installed -> PackageIndex available -> Constraints installed available reason -empty installed available = Constraints pkgs mempty +empty installed available = Constraints pkgs pairs mempty where pkgs = PackageIndex.fromList . map toInstalledOrAvailable $ mergeBy (\a b -> packageId a `compare` packageId b) - (allPackagesInOrder installed) - (allPackagesInOrder available) + (PackageIndex.allPackages installed) + (PackageIndex.allPackages available) toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a - toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a + toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a + -- pick up cases like base-3 and 4 where one version depends on the other: + pairs = Map.fromList + [ (name, (packageVersion pkgid1, packageVersion pkgid2)) + | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed + , let name = packageName pkg1 + pkgid1 = packageId pkg1 + pkgid2 = packageId pkg2 + , any ((pkgid1==) . packageId) (depends pkg2) + || any ((pkgid2==) . packageId) (depends pkg1) ] + -- | 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 (Constraints available _ _) = available -data Satisfiable a reason - = Satisfiable a +isPaired :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIdentifier -> Maybe PackageIdentifier +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])] @@ -144,18 +163,19 @@ => TaggedDependency -> reason -> Constraints installed available reason - -> Satisfiable (Constraints installed available reason) reason + -> Satisfiable (Constraints installed available reason) + [PackageIdentifier] reason constrain (TaggedDependency installedConstraint (Dependency name versionRange)) - reason constraints@(Constraints available excluded) + reason constraints@(Constraints available paired excluded) | not anyRemaining = if null conflicts then Unsatisfiable else ConflictsWith conflicts | otherwise - = let constraints' = Constraints available' excluded' + = let constraints' = Constraints available' paired excluded' in assert (constraints `transitionsTo` constraints') $ - Satisfiable constraints' + Satisfiable constraints' (map packageId newExcluded) where -- This tells us if any packages would remain at all for this package name if @@ -184,39 +204,39 @@ -- Applying the constraint means adding exclusions for the packages that -- we're just freshly excluding, ie the ones we're removing from available. - excluded' = addNewExcluded . addOldExcluded $ excluded - addNewExcluded index = foldl' (flip exclude) index availableChoices where + excluded' = foldl' (flip PackageIndex.insert) excluded + (newExcluded ++ oldExcluded) + + newExcluded = catMaybes (map exclude availableChoices) where exclude pkg | not (satisfiesVersionConstraint pkg) - = PackageIndex.insert $ ExcludedPackage pkgid [] [reason] + = Just (ExcludedPackage pkgid [] [reason]) | installedConstraint == NoInstalledConstraint - = id + = Nothing | otherwise = case pkg of - InstalledOnly _ -> id - AvailableOnly _ -> PackageIndex.insert - (ExcludedPackage pkgid [reason] []) + InstalledOnly _ -> Nothing + AvailableOnly _ -> Just (ExcludedPackage pkgid [reason] []) InstalledAndAvailable _ _ -> case PackageIndex.lookupPackageId excluded pkgid of - Just (ExcludedPackage _ avail both) -> - PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both) - Nothing -> - PackageIndex.insert (ExcludedPackage pkgid [reason] []) + Just (ExcludedPackage _ avail both) + -> Just (ExcludedPackage pkgid (reason:avail) both) + Nothing -> Just (ExcludedPackage pkgid [reason] []) where pkgid = packageId pkg -- Additionally we have to add extra exclusions for any already-excluded -- packages that happen to be covered by the (inverse of the) constraint. - addOldExcluded = flip (foldl' (flip exclude)) excludedChoices where + 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) - = PackageIndex.insert (ExcludedPackage pkgid avail (reason:both)) + = 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 - = PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both) - | otherwise = id + = Just (ExcludedPackage pkgid (reason:avail) both) + | otherwise = Nothing -- util definitions availableChoices = PackageIndex.lookupPackageName available name @@ -225,8 +245,15 @@ satisfiesConstraint pkg = satisfiesVersionConstraint pkg && satisfiesInstallStateConstraint pkg - satisfiesVersionConstraint pkg = - packageVersion pkg `withinRange` versionRange + 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 satisfiesInstallStateConstraint = case installedConstraint of NoInstalledConstraint -> \_ -> True @@ -238,7 +265,7 @@ => Constraints installed available reason -> Dependency -> [(PackageIdentifier, [reason])] -conflicting (Constraints _ excluded) dep = +conflicting (Constraints _ _ excluded) dep = [ (pkgid, reasonsAvail ++ reasonsAll) --TODO | ExcludedPackage pkgid reasonsAvail reasonsAll <- PackageIndex.lookupDependency excluded dep ] diff --git a/Distribution/Client/Dependency/TopDown/Types.hs b/Distribution/Client/Dependency/TopDown/Types.hs --- a/Distribution/Client/Dependency/TopDown/Types.hs +++ b/Distribution/Client/Dependency/TopDown/Types.hs @@ -17,7 +17,8 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Package - ( PackageIdentifier, Dependency, Package(packageId) ) + ( PackageIdentifier, Dependency + , Package(packageId), PackageFixedDeps(depends) ) import Distribution.PackageDescription ( FlagAssignment ) @@ -59,6 +60,9 @@ instance Package InstalledPackage where packageId (InstalledPackage p _ _) = packageId p + +instance PackageFixedDeps InstalledPackage where + depends (InstalledPackage _ _ deps) = deps instance Package UnconfiguredPackage where packageId (UnconfiguredPackage p _ _) = packageId p diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs --- a/Distribution/Client/Dependency/Types.hs +++ b/Distribution/Client/Dependency/Types.hs @@ -13,7 +13,11 @@ module Distribution.Client.Dependency.Types ( PackageName, DependencyResolver, - PackageVersionPreference(..), + + PackagePreference(..), + PackageVersionPreference, + PackageInstalledPreference(..), + Progress(..), foldProgress, ) where @@ -26,6 +30,10 @@ ( InstalledPackageInfo ) import Distribution.Simple.PackageIndex ( PackageIndex ) +import Distribution.Package + ( PackageName ) +import Distribution.Version + ( VersionRange ) import Distribution.Compiler ( CompilerId ) import Distribution.System @@ -33,8 +41,6 @@ import Prelude hiding (fail) -type PackageName = String - -- | 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. @@ -48,17 +54,33 @@ -> CompilerId -> PackageIndex InstalledPackageInfo -> PackageIndex AvailablePackage - -> (PackageName -> PackageVersionPreference) + -> (PackageName -> PackagePreference) -> [UnresolvedDependency] -> Progress String String [InstallPlan.PlanPackage] -- | A per-package preference on the version. It is a soft constraint that the --- 'DependencyResolver' should try to respect where possible. +-- 'DependencyResolver' should try to respect where possible. It consists of +-- a 'PackageInstalledPreference' which says if we prefer versions of packages +-- that are already installed. It also hase a 'PackageVersionPreference' which +-- is a suggested constraint on the version number. The resolver should try to +-- use package versions that satisfy the suggested version constraint. -- -- It is not specified if preferences on some packages are more important than -- others. -- -data PackageVersionPreference = PreferInstalled | PreferLatest +data PackagePreference = PackagePreference + PackageInstalledPreference + PackageVersionPreference + +-- | A suggested constraint on the version number. The resolver should try to +-- use package versions that satisfy the suggested version constraint. +-- +type PackageVersionPreference = VersionRange + +-- | Wether we prefer an installed version of a package or simply the latest +-- version. +-- +data PackageInstalledPreference = PreferInstalled | PreferLatest -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -23,10 +23,11 @@ import Distribution.Client.Types ( UnresolvedDependency (..), AvailablePackage(..) - , AvailablePackageSource(..) + , AvailablePackageSource(..), AvailablePackageDb(..) , Repo(..), RemoteRepo(..), LocalRepo(..) ) import Distribution.Client.Dependency - ( resolveDependenciesWithProgress, PackagesVersionPreference(..) ) + ( resolveDependenciesWithProgress, packagesPreference + , PackagesInstalledPreference(..) ) import Distribution.Client.Dependency.Types ( foldProgress ) import Distribution.Client.IndexUtils as IndexUtils @@ -35,7 +36,7 @@ import Distribution.Client.HttpUtils (getHTTP, isOldHackageURI) import Distribution.Package - ( PackageIdentifier(..), Dependency(..) ) + ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Compiler ( Compiler(compilerId), PackageDB ) @@ -147,7 +148,8 @@ -> IO () fetch verbosity packageDB repos comp conf deps = do installed <- getInstalledPackages verbosity comp packageDB conf - available <- getAvailablePackages verbosity repos + AvailablePackageDb available versionPref + <- getAvailablePackages verbosity repos deps' <- IndexUtils.disambiguateDependencies available deps let -- Hide the packages given on the command line so that the dep resolver @@ -161,7 +163,9 @@ let progress = resolveDependenciesWithProgress buildOS buildArch (compilerId comp) - installed' available PreferLatestForSelected deps' + installed' available + (packagesPreference PreferLatestForSelected versionPref) + deps' notice verbosity "Resolving dependencies..." maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) (return . Left) (return . Right) progress @@ -191,8 +195,8 @@ -- the tarball for a given @PackageIdentifer@ is stored. packageDir :: Repo -> PackageIdentifier -> FilePath packageDir repo pkgid = repoLocalDir repo - pkgName pkgid - display (pkgVersion pkgid) + display (packageName pkgid) + display (packageVersion pkgid) -- | Generate the URI of the tarball for a given package. packageURI :: RemoteRepo -> PackageIdentifier -> URI @@ -200,8 +204,8 @@ (remoteRepoURI repo) { uriPath = FilePath.Posix.joinPath [uriPath (remoteRepoURI repo) - ,pkgName pkgid - ,display (pkgVersion pkgid) + ,display (packageName pkgid) + ,display (packageVersion pkgid) ,display pkgid <.> "tar.gz"] } packageURI repo pkgid = diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -12,7 +12,10 @@ ----------------------------------------------------------------------------- module Distribution.Client.IndexUtils ( getAvailablePackages, - readRepoIndex, + + readPackageIndexFile, + parseRepoIndex, + disambiguatePackageName, disambiguateDependencies ) where @@ -20,83 +23,100 @@ import qualified Distribution.Client.Tar as Tar import Distribution.Client.Types ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), Repo(..), RemoteRepo(..) ) + , AvailablePackageSource(..), Repo(..), RemoteRepo(..) + , AvailablePackageDb(..) ) import Distribution.Package - ( PackageIdentifier(..), Package(..), Dependency(Dependency) ) + ( PackageId, PackageIdentifier(..), PackageName(..), Package(..) + , Dependency(Dependency) ) import Distribution.Simple.PackageIndex (PackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parse ( parsePackageDescription ) import Distribution.ParseUtils ( ParseResult(..) ) +import Distribution.Version + ( VersionRange(IntersectVersionRanges) ) import Distribution.Text - ( simpleParse ) + ( display, simpleParse ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) +import Data.List (isPrefixOf) import Data.Monoid (Monoid(..)) +import qualified Data.Map as Map +import Control.Monad (MonadPlus(mplus)) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Data.ByteString.Lazy (ByteString) +import qualified Codec.Compression.GZip as GZip (decompress) import System.FilePath ((), takeExtension, splitDirectories, normalise) +import System.FilePath.Posix as FilePath.Posix + ( takeFileName ) import System.IO.Error (isDoesNotExistError) - -getAvailablePackages :: Verbosity -> [Repo] - -> IO (PackageIndex AvailablePackage) +-- | 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 +-- 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb getAvailablePackages verbosity repos = do info verbosity "Reading available packages..." pkgss <- mapM (readRepoIndex verbosity) repos - evaluate (mconcat pkgss) + let (pkgs, prefs) = mconcat pkgss + prefs' = Map.fromListWith IntersectVersionRanges + [ (name, range) | Dependency name range <- prefs ] + evaluate pkgs + evaluate prefs' + return AvailablePackageDb { + packageIndex = pkgs, + packagePreferences = prefs' + } -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. -- -readRepoIndex :: Verbosity -> Repo -> IO (PackageIndex AvailablePackage) -readRepoIndex verbosity repo = - handleNotFound $ do - let indexFile = repoLocalDir repo "00-index.tar" - pkgs <- either fail return . parseRepoIndex =<< BS.readFile indexFile - evaluate (PackageIndex.fromList pkgs) +-- All the 'AvailablePackage'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 + let indexFile = repoLocalDir repo "00-index.tar" + (pkgs, prefs) <- either fail return + . foldlTarball extract ([], []) + =<< BS.readFile indexFile - where - -- | Parse a repository index file from a 'ByteString'. - -- - -- All the 'AvailablePackage's are marked as having come from the given 'Repo'. - -- - parseRepoIndex :: ByteString -> Either String [AvailablePackage] - parseRepoIndex = either Left (Right . catMaybes . map extractPkg) - . check [] . Tar.read + pkgIndex <- evaluate $ PackageIndex.fromList + [ AvailablePackage { + packageInfoId = pkgid, + packageDescription = pkg, + packageSource = RepoTarballPackage repo + } + | (pkgid, pkg) <- pkgs] - check _ (Tar.Fail err) = Left err - check ok Tar.Done = Right ok - check ok (Tar.Next e es) = check (e:ok) es + return (pkgIndex, prefs) - extractPkg :: Tar.Entry -> Maybe AvailablePackage - extractPkg entry - | takeExtension fileName == ".cabal" - = case splitDirectories (normalise fileName) of - [pkgname,vers,_] -> case simpleParse vers of - Just ver -> Just AvailablePackage { - packageInfoId = PackageIdentifier pkgname ver, - packageDescription = descr, - packageSource = RepoTarballPackage repo - } - _ -> Nothing - where - parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack - . Tar.fileContent $ entry - descr = case parsed of - ParseOk _ d -> d - _ -> error $ "Couldn't read cabal file " - ++ show fileName - _ -> Nothing + 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 + | takeFileName (Tar.fileName entry) == "preferred-versions" + = Just . parsePreferredVersions + . BS.Char8.unpack . Tar.fileContent $ entry | otherwise = Nothing - where - fileName = Tar.fileName entry handleNotFound action = catch action $ \e -> if isDoesNotExistError e then do @@ -110,6 +130,68 @@ return mempty else ioError e +parsePreferredVersions :: String -> [Dependency] +parsePreferredVersions = catMaybes + . map simpleParse + . filter (not . isPrefixOf "--") + . lines + +-- | 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 +-- the hackage package index. +-- +-- It takes a function to map a 'GenericPackageDescription' into any more +-- specific instance of 'Package' that you might want to use. In the simple +-- case you can just use @\_ p -> p@ here. +-- +readPackageIndexFile :: Package pkg + => (PackageId -> GenericPackageDescription -> pkg) + -> FilePath -> IO (PackageIndex pkg) +readPackageIndexFile mkPkg indexFile = do + pkgs <- either fail return + . parseRepoIndex + . GZip.decompress + =<< BS.readFile indexFile + + evaluate $ PackageIndex.fromList + [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] + +-- | 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) [] + +extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) +extractPkg entry + | takeExtension fileName == ".cabal" + = case splitDirectories (normalise fileName) of + [pkgname,vers,_] -> case simpleParse vers of + Just ver -> Just (pkgid, descr) + where + pkgid = PackageIdentifier (PackageName pkgname) ver + parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack + . Tar.fileContent $ entry + descr = case parsed of + ParseOk _ d -> d + _ -> error $ "Couldn't read cabal file " + ++ show fileName + _ -> Nothing + _ -> Nothing + | otherwise = Nothing + where + fileName = Tar.fileName entry + +foldlTarball :: (a -> Tar.Entry -> a) -> a + -> ByteString -> Either String a +foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read + where + check _ (Tar.Fail err) = Left err + check ok Tar.Done = Right ok + check ok (Tar.Next e es) = check (e:ok) es + -- | Disambiguate a set of packages using 'disambiguatePackage' and report any -- ambiguities to the user. -- @@ -126,9 +208,9 @@ (_, Left name)) <- zip deps names ] ambigious -> die $ unlines [ if null matches - then "There is no package named " ++ name - else "The package name " ++ name ++ "is ambigious. " - ++ "It could be: " ++ intercalate ", " matches + then "There is no package named " ++ display name + else "The package name " ++ display name ++ "is ambigious. " + ++ "It could be: " ++ intercalate ", " (map display matches) | (name, matches) <- ambigious ] -- | Given an index of known packages and a package name, figure out which one it @@ -138,9 +220,9 @@ -- that case it is ambigious. -- disambiguatePackageName :: PackageIndex AvailablePackage - -> String - -> Either String [String] -disambiguatePackageName index name = + -> PackageName + -> Either PackageName [PackageName] +disambiguatePackageName index (PackageName name) = case PackageIndex.searchByName index name of PackageIndex.None -> Right [] PackageIndex.Unambiguous pkgs -> Left (pkgName (packageId (head pkgs))) diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -16,22 +16,25 @@ ) where import Data.List - ( unfoldr ) + ( unfoldr, find, nub, sort ) import Data.Maybe - ( isJust ) + ( isJust, fromMaybe ) import Control.Exception as Exception - ( handle, Exception ) + ( handle, handleJust, Exception(IOException) ) import Control.Monad - ( when, unless, forM_ ) + ( when, unless ) import System.Directory ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) import System.FilePath ( (), (<.>), takeDirectory ) import System.IO ( openFile, IOMode(AppendMode) ) +import System.IO.Error + ( isDoesNotExistError, ioeGetFileName ) import Distribution.Client.Dependency - ( resolveDependenciesWithProgress, PackagesVersionPreference(..) + ( resolveDependenciesWithProgress + , packagesPreference, PackagesInstalledPreference(..) , upgradableDependencies ) import Distribution.Client.Dependency.Types (Progress(..), foldProgress) import Distribution.Client.Fetch (fetchPackage) @@ -47,7 +50,8 @@ import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Available ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), Repo(..), ConfiguredPackage(..) + , AvailablePackageSource(..), AvailablePackageDb(..) + , Repo(..), ConfiguredPackage(..) , BuildResult, BuildFailure(..), BuildSuccess(..) , DocsResult(..), TestsResult(..), RemoteRepo(..) ) import Distribution.Client.SetupWrapper @@ -71,16 +75,19 @@ import Distribution.Simple.Setup ( flagToMaybe ) import Distribution.Simple.Utils - ( defaultPackageDesc, inDir, rawSystemExit, withTempDirectory ) + ( defaultPackageDesc, rawSystemExit, withTempDirectory, comparing ) import Distribution.Simple.InstallDirs ( fromPathTemplate, toPathTemplate , initialPathTemplateEnv, substPathTemplate ) import Distribution.Package - ( PackageIdentifier(..), Package(..), thisPackageVersion - , Dependency(..) ) + ( PackageIdentifier, packageName, packageVersion + , Package(..), PackageFixedDeps(..) + , Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription - ( PackageDescription, readPackageDescription ) + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) import Distribution.InstalledPackageInfo @@ -89,6 +96,8 @@ ( Version, VersionRange(AnyVersion, ThisVersion) ) import Distribution.Simple.Utils as Utils ( notice, info, warn, die, intercalate ) +import Distribution.Client.Utils + ( inDir, mergeBy, MergeResult(..) ) import Distribution.System ( OS(Windows), buildOS, Arch, buildArch ) import Distribution.Text @@ -132,7 +141,7 @@ comp installFlags deps type Planner = Maybe (PackageIndex InstalledPackageInfo) - -> PackageIndex AvailablePackage + -> AvailablePackageDb -> IO (Progress String String InstallPlan) -- |Installs the packages generated by a planner. @@ -166,7 +175,7 @@ ++ "the --reinstall flag." when (dryRun || verbosity >= verbose) $ - printDryRun verbosity installPlan + printDryRun verbosity installed installPlan unless dryRun $ do logsDir <- defaultLogsDir @@ -186,7 +195,7 @@ BuildReports.storeAnonymous buildReports BuildReports.storeLocal buildReports when useDetailedBuildReports $ - storeDetailedBuildReports logsDir buildReports + storeDetailedBuildReports verbosity logsDir buildReports symlinkBinaries verbosity configFlags installFlags installPlan' printBuildFailures installPlan' @@ -222,25 +231,44 @@ libVersion = Cabal.flagToMaybe (installCabalVersion installFlags) } -storeDetailedBuildReports :: FilePath -> [(BuildReports.BuildReport, Repo)] -> IO () -storeDetailedBuildReports logsDir reports - = forM_ reports $ \(report,repo) -> - do buildLog <- readFile (logsDir display (BuildReports.package report) <.> "log") - case repoKind repo of - Left remoteRepo - -> do dotCabal <- defaultCabalDir - let destDir = dotCabal "reports" remoteRepoName remoteRepo - dest = destDir display (BuildReports.package report) <.> "log" - createDirectoryIfMissing True destDir -- FIXME - writeFile dest (show (BuildReports.show report, buildLog)) - Right{} -> return () - +storeDetailedBuildReports :: Verbosity -> FilePath + -> [(BuildReports.BuildReport, Repo)] -> IO () +storeDetailedBuildReports verbosity logsDir reports = sequence_ + [ do dotCabal <- defaultCabalDir + let logFileName = display (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = dotCabal "reports" remoteRepoName remoteRepo + reportFile = reportsDir logFileName + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (BuildReports.show report, buildLog)) + + | (report, Repo { repoKind = Left remoteRepo }) <- reports + , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] + + where + isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True + isLikelyToHaveLogFile BuildReports.BuildFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallOk {} = True + isLikelyToHaveLogFile _ = False + + handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> + warn verbosity $ "Missing log file for build report: " + ++ fromMaybe "" (ioeGetFileName ioe) + + missingFile (IOException ioe) + | isDoesNotExistError ioe = Just ioe + missingFile _ = Nothing + -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. -- planLocalPackage :: Verbosity -> Compiler -> Cabal.ConfigFlags -> Planner -planLocalPackage verbosity comp configFlags installed available = do +planLocalPackage verbosity comp configFlags installed + (AvailablePackageDb available versionPrefs) = do pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity let -- The trick is, we add the local package to the available index and -- remove it from the installed index. Then we ask to resolve a @@ -259,29 +287,36 @@ } return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp) - installed' available' PreferLatestForSelected [localPkgDep] + installed' available' + (packagesPreference PreferLatestForSelected versionPrefs) + [localPkgDep] -- | Make an 'InstallPlan' for the given dependencies. -- -planRepoPackages :: PackagesVersionPreference -> Compiler -> InstallFlags +planRepoPackages :: PackagesInstalledPreference -> Compiler -> InstallFlags -> [UnresolvedDependency] -> Planner -planRepoPackages pref comp installFlags deps installed available = do +planRepoPackages installedPref comp installFlags deps installed + (AvailablePackageDb available versionPrefs) = do deps' <- IndexUtils.disambiguateDependencies available deps let installed' | Cabal.fromFlagOrDefault False (installReinstall installFlags) = fmap (hideGivenDeps deps') installed | otherwise = installed return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp) - installed' available pref deps' + installed' available + (packagesPreference installedPref versionPrefs) + deps' where hideGivenDeps pkgs index = foldr PackageIndex.deletePackageName index [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] planUpgradePackages :: Compiler -> Planner -planUpgradePackages comp (Just installed) available = return $ +planUpgradePackages comp (Just installed) + (AvailablePackageDb available versionPrefs) = return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp) - (Just installed) available PreferAllLatest + (Just installed) available + (packagesPreference PreferAllLatest versionPrefs) [ UnresolvedDependency dep [] | dep <- upgradableDependencies installed available ] planUpgradePackages comp _ _ = @@ -289,21 +324,48 @@ ++ " does not track installed packages so cabal cannot figure out what" ++ " packages need to be upgraded." -printDryRun :: Verbosity -> InstallPlan -> IO () -printDryRun verbosity plan = case unfoldr next plan of +printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackageInfo) + -> InstallPlan -> IO () +printDryRun verbosity minstalled plan = case unfoldr next plan of [] -> return () - pkgs -> notice verbosity $ unlines $ - "In order, the following would be installed:" - : map display pkgs + 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 where next plan' = case InstallPlan.ready plan' of [] -> Nothing - (pkg:_) -> Just (pkgid, InstallPlan.completed pkgid result plan') + (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan') where pkgid = packageId 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 minstalled of + Nothing -> "" + Just installed -> + 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 + $ mergeBy (comparing packageName) + (nub . sort . depends $ pkg) + (nub . sort . depends $ pkg') + 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 + symlinkBinaries :: Verbosity -> Cabal.ConfigFlags -> InstallFlags @@ -343,6 +405,7 @@ printFailureReason reason = case reason of DependentFailed pkgid -> " depends on " ++ display pkgid ++ " which failed to install." + DownloadFailed _ -> " failed while downloading the package." UnpackFailed e -> " failed while unpacking the package." ++ " The exception was:\n " ++ show e ConfigureFailed e -> " failed during the configure step." @@ -405,20 +468,22 @@ installAvailablePackage _ _ LocalUnpackedPackage installPkg = installPkg Nothing -installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg = do - pkgPath <- fetchPackage verbosity repo pkgid - tmp <- getTemporaryDirectory - let tmpDirPath = tmp ("TMP" ++ display pkgid) - path = tmpDirPath display pkgid - onFailure UnpackFailed $ withTempDirectory verbosity tmpDirPath $ do - info verbosity $ "Extracting " ++ pkgPath ++ " to " ++ tmpDirPath ++ "..." - extractTarGzFile tmpDirPath pkgPath - let descFilePath = tmpDirPath display pkgid - pkgName pkgid <.> "cabal" - exists <- doesFileExist descFilePath - when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath - installPkg (Just path) +installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg = + onFailure DownloadFailed $ do + pkgPath <- fetchPackage verbosity repo pkgid + tmp <- getTemporaryDirectory + let tmpDirPath = tmp ("TMP" ++ display pkgid) + path = tmpDirPath display pkgid + onFailure UnpackFailed $ withTempDirectory verbosity tmpDirPath $ do + info verbosity $ "Extracting " ++ pkgPath + ++ " to " ++ tmpDirPath ++ "..." + extractTarGzFile tmpDirPath pkgPath + let descFilePath = tmpDirPath display pkgid + display (packageName pkgid) <.> "cabal" + exists <- doesFileExist descFilePath + when (not exists) $ + die $ "Package .cabal file not found: " ++ show descFilePath + installPkg (Just path) installUnpackedPackage :: Verbosity -> SetupScriptOptions diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -48,8 +48,8 @@ ( AvailablePackage(packageDescription), ConfiguredPackage(..) , BuildFailure, BuildSuccess ) import Distribution.Package - ( PackageIdentifier(..), Package(..), PackageFixedDeps(..) - , packageName, Dependency(..) ) + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , PackageFixedDeps(..), Dependency(..) ) import Distribution.Version ( Version, withinRange ) import Distribution.InstalledPackageInfo @@ -146,7 +146,7 @@ planIndex :: PackageIndex PlanPackage, planGraph :: Graph, planGraphRev :: Graph, - planPkgIdOf :: Graph.Vertex -> PackageIdentifier, + planPkgOf :: Graph.Vertex -> PlanPackage, planVertexOf :: PackageIdentifier -> Graph.Vertex, planOS :: OS, planArch :: Arch, @@ -170,7 +170,7 @@ planIndex = index, planGraph = graph, planGraphRev = Graph.transposeG graph, - planPkgIdOf = vertexToPkgId, + planPkgOf = vertexToPkgId, planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, planOS = os, planArch = arch, @@ -240,14 +240,14 @@ failures = PackageIndex.fromList $ Failed pkg buildResult : [ Failed pkg' buildResult' - | Just pkg' <- map (lookupConfiguredPackage' plan) + | Just pkg' <- map checkConfiguredPackage $ packagesThatDependOn plan pkgid ] -- | lookup the reachable packages in the reverse dependency graph -- packagesThatDependOn :: InstallPlan - -> PackageIdentifier -> [PackageIdentifier] -packagesThatDependOn plan = map (planPkgIdOf plan) + -> PackageIdentifier -> [PlanPackage] +packagesThatDependOn plan = map (planPkgOf plan) . tail . Graph.reachable (planGraphRev plan) . planVertexOf plan @@ -261,15 +261,13 @@ Just (Configured pkg) -> pkg _ -> internalError $ "not configured or no such pkg " ++ display pkgid --- | lookup a package that we expect to be in the configured or failed state +-- | check a package that we expect to be in the configured or failed state -- -lookupConfiguredPackage' :: InstallPlan - -> PackageIdentifier -> Maybe ConfiguredPackage -lookupConfiguredPackage' plan pkgid = - case PackageIndex.lookupPackageId (planIndex plan) pkgid of - Just (Configured pkg) -> Just pkg - Just (Failed _ _) -> Nothing - _ -> internalError $ "not configured or no such pkg " ++ display pkgid +checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage +checkConfiguredPackage (Configured pkg) = Just pkg +checkConfiguredPackage (Failed _ _) = Nothing +checkConfiguredPackage pkg = + internalError $ "not configured or no such pkg " ++ display (packageId pkg) -- ------------------------------------------------------------ -- * Checking valididy of plans @@ -288,7 +286,7 @@ PackageInvalid ConfiguredPackage [PackageProblem] | PackageMissingDeps PlanPackage [PackageIdentifier] | PackageCycle [PlanPackage] - | PackageInconsistency String [(PackageIdentifier, Version)] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] | PackageStateInvalid PlanPackage PlanPackage showPlanProblem :: PlanProblem -> String @@ -308,7 +306,7 @@ ++ intercalate ", " (map (display.packageId) cycleGroup) showPlanProblem (PackageInconsistency name inconsistencies) = - "Package " ++ name + "Package " ++ display name ++ " is required by several packages," ++ " but they require inconsistent versions:\n" ++ unlines [ " package " ++ display pkg ++ " requires " diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -23,7 +23,8 @@ import Distribution.Text ( Text(disp), display ) -import Distribution.Package (PackageIdentifier(..), Package(..)) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..) ) import Distribution.License (License) import qualified Distribution.PackageDescription as Available import Distribution.InstalledPackageInfo (InstalledPackageInfo) @@ -34,7 +35,8 @@ import Distribution.Client.IndexUtils (getAvailablePackages) import Distribution.Client.Setup (ListFlags(..)) -import Distribution.Client.Types (AvailablePackage(..), Repo) +import Distribution.Client.Types + ( AvailablePackage(..), Repo, AvailablePackageDb(..) ) import Distribution.Simple.Configure (getInstalledPackages) import Distribution.Simple.Compiler (Compiler,PackageDB) import Distribution.Simple.Program (ProgramConfiguration) @@ -54,7 +56,7 @@ -> IO () list verbosity packageDB repos comp conf listFlags pats = do Just installed <- getInstalledPackages verbosity comp packageDB conf - available <- getAvailablePackages verbosity repos + AvailablePackageDb available _ <- getAvailablePackages verbosity repos let pkgs | null pats = (PackageIndex.allPackages installed ,PackageIndex.allPackages available) | otherwise = @@ -66,7 +68,7 @@ if simpleOutput then putStr $ unlines - [ name pkg ++ " " ++ display version + [ display(name pkg) ++ " " ++ display version | pkg <- matches , version <- if onlyInstalled then installedVersions pkg @@ -87,7 +89,7 @@ -- package name and covers all installed and avilable versions. -- data PackageDisplayInfo = PackageDisplayInfo { - name :: String, + name :: PackageName, installedVersions :: [Version], availableVersions :: [Version], homepage :: String, @@ -99,7 +101,7 @@ showPackageInfo :: PackageDisplayInfo -> String showPackageInfo pkg = renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - text " *" <+> text (name pkg) + text " *" <+> disp (name pkg) $+$ (nest 6 $ vcat [ maybeShow (availableVersions pkg) diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -25,11 +25,13 @@ import Distribution.Version ( Version(..), VersionRange(..), withinRange ) import Distribution.Package - ( PackageIdentifier(..), Package(..), packageName, packageVersion - , Dependency(..) ) + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , packageVersion, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) - , PackageDescription(..), BuildType(..), readPackageDescription ) + , PackageDescription(..), BuildType(..) ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Simple.Configure @@ -49,20 +51,20 @@ import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Utils ( die, debug, info, cabalVersion, findPackageDesc, comparing - , createDirectoryIfMissingVerbose, inDir ) + , createDirectoryIfMissingVerbose ) +import Distribution.Client.Utils + ( moreRecentFile, rewriteFile, inDir ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity ) -import System.Directory ( doesFileExist, getModificationTime, getCurrentDirectory ) +import System.Directory ( doesFileExist, getCurrentDirectory ) import System.FilePath ( (), (<.>) ) -import System.IO.Error ( isDoesNotExistError ) import System.IO ( Handle ) import System.Exit ( ExitCode(..), exitWith ) import System.Process ( runProcess, waitForProcess ) import Control.Monad ( when, unless ) -import Control.Exception ( evaluate ) import Data.List ( maximumBy ) import Data.Maybe ( fromMaybe, isJust ) import Data.Monoid ( Monoid(mempty) ) @@ -168,7 +170,9 @@ invokeSetupScript (mkargs cabalLibVersion) where - workingDir = fromMaybe "" (useWorkingDir options) + workingDir = case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir setupDir = workingDir useDistPref options "setup" setupVersionFile = setupDir "setup" <.> "version" setupProgFile = setupDir "setup" <.> exeExtension @@ -192,7 +196,7 @@ installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration -> IO Version - installedCabalVersion _ _ _ | packageName pkg == "Cabal" = + installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" = return (packageVersion pkg) installedCabalVersion options' comp conf = do index <- case usePackageIndex options' of @@ -201,7 +205,7 @@ `fmap` getInstalledPackages verbosity comp UserPackageDB conf -- user packages are *allowed* here, no portability problem - let cabalDep = Dependency "Cabal" (useCabalVersion options) + let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options) case PackageIndex.lookupDependency index cabalDep of [] -> die $ "The package requires Cabal library version " ++ display (useCabalVersion options) @@ -274,11 +278,12 @@ rawSystemProgramConf verbosity ghcProgram conf $ ghcVerbosityOptions verbosity ++ ["--make", setupHsFile, "-o", setupProgFile - ,"-odir", setupDir, "-hidir", setupDir] - ++ if packageName pkg == "Cabal" - then ["-i", "-i."] - else ["-i", "-package", display cabalPkgid ] - where cabalPkgid = PackageIdentifier "Cabal" cabalLibVersion + ,"-odir", setupDir, "-hidir", setupDir + ,"-i", "-i" ++ workingDir ] + ++ if packageName pkg == PackageName "Cabal" + then [] + else ["-package", display cabalPkgid] + where cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion invokeSetupScript :: [String] -> IO () invokeSetupScript args = do @@ -293,36 +298,3 @@ Nothing (useLoggingHandle options) (useLoggingHandle options) exitCode <- waitForProcess process unless (exitCode == ExitSuccess) $ exitWith exitCode - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - --- | Compare the modification times of two files to see if the first is newer --- than the second. The first file must exist but the second need not. --- The expected use case is when the second file is generated using the first. --- In this use case, if the result is True then the second file is out of date. --- -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- -rewriteFile :: FilePath -> String -> IO () -rewriteFile path newContent = - flip catch mightNotExist $ do - existingContent <- readFile path - evaluate (length existingContent) - unless (existingContent == newContent) $ - writeFile path newContent - where - mightNotExist e | isDoesNotExistError e = writeFile path newContent - | otherwise = ioError e diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -5,13 +5,16 @@ sdist ) where import Distribution.Simple.SrcDist - ( printPackageProblems, prepareTree, prepareSnapshotTree ) + ( printPackageProblems, prepareTree + , prepareSnapshotTree, snapshotPackage ) import Distribution.Client.Tar (createTarGzFile) import Distribution.Package ( Package(..) ) import Distribution.PackageDescription - ( PackageDescription, readPackageDescription ) + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) import Distribution.Simple.Utils ( withTempDirectory , defaultPackageDesc , die, warn, notice, setupMessage ) @@ -52,13 +55,14 @@ withTempDirectory verbosity tmpDir $ do - setupMessage verbosity "Building source dist for" (packageId pkg) + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + setupMessage verbosity "Building source dist for" (packageId pkg') + if snapshot - then getClockTime >>= toCalendarTime - >>= prepareSnapshotTree verbosity pkg mb_lbi - distPref tmpDir knownSuffixHandlers - else prepareTree verbosity pkg mb_lbi - distPref tmpDir knownSuffixHandlers + 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 @@ -66,6 +70,7 @@ verbosity = fromFlag (sDistVerbosity flags) snapshot = fromFlag (sDistSnapshot flags) distPref = fromFlag (sDistDistPref flags) + pps = knownSuffixHandlers -- |Create an archive from a tree of source files, and clean up the tree. createArchive :: Verbosity diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -57,11 +57,11 @@ checkEntryNames ) where -import Data.Char (ord) -import Data.Int (Int64) -import Data.List (foldl') -import Data.Monoid (Monoid(..)) -import Numeric (readOct, showOct) +import Data.Char (ord) +import Data.Int (Int64) +import Data.List (foldl') +import Control.Monad (MonadPlus(mplus)) +import Numeric (readOct, showOct) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 @@ -409,8 +409,8 @@ checkEntryName :: Entry -> Maybe String checkEntryName entry = case fileType entry of - HardLink -> check (fileName entry) `mappend` check (linkTarget entry) - SymbolicLink -> check (fileName entry) `mappend` check (linkTarget entry) + HardLink -> check (fileName entry) `mplus` check (linkTarget entry) + SymbolicLink -> check (fileName entry) `mplus` check (linkTarget entry) _ -> check (fileName entry) where diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -13,11 +13,16 @@ module Distribution.Client.Types where import Distribution.Package - ( PackageIdentifier(..), Package(..), PackageFixedDeps(..) - , Dependency ) + ( PackageName, PackageIdentifier(..), Package(..) + , PackageFixedDeps(..), Dependency ) import Distribution.PackageDescription ( GenericPackageDescription, FlagAssignment ) +import Distribution.Simple.PackageIndex + ( PackageIndex ) +import Distribution.Version + ( VersionRange ) +import Data.Map (Map) import Network.URI (URI) import Control.Exception ( Exception ) @@ -25,6 +30,13 @@ newtype Username = Username { unUsername :: String } newtype Password = Password { unPassword :: String } +-- | This is the information we get from a @00-index.tar.gz@ hackage index. +-- +data AvailablePackageDb = AvailablePackageDb { + packageIndex :: PackageIndex AvailablePackage, + packagePreferences :: Map PackageName VersionRange +} + -- | 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 @@ -100,6 +112,7 @@ type BuildResult = Either BuildFailure BuildSuccess data BuildFailure = DependentFailed PackageIdentifier + | DownloadFailed Exception | UnpackFailed Exception | ConfigureFailed Exception | BuildFailed Exception diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -5,12 +5,17 @@ import qualified Data.ByteString.Lazy as BS import System.FilePath ( (<.>), splitFileName ) +import Control.Monad + ( unless ) import System.IO ( openBinaryTempFile, hClose ) +import System.IO.Error + ( isDoesNotExistError ) import System.Directory - ( removeFile, renameFile ) + ( removeFile, renameFile, doesFileExist, getModificationTime + , getCurrentDirectory, setCurrentDirectory ) import qualified Control.Exception as Exception - ( handle, throwIO ) + ( handle, throwIO, evaluate, finally ) -- | Generic merging utility. For sorted input lists this is a full outer join. -- @@ -57,3 +62,40 @@ --TODO: remove this when takeDirectory/splitFileName is fixed -- to always return a valid dir (targetDir_,targetName) = splitFileName targetFile + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +-- +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catch mightNotExist $ do + existingContent <- readFile path + Exception.evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFile path newContent + where + mightNotExist e | isDoesNotExistError e = writeFile path newContent + | otherwise = ioError e + +-- | Executes the action in the specified directory. +inDir :: Maybe FilePath -> IO () -> IO () +inDir Nothing m = m +inDir (Just d) m = do + old <- getCurrentDirectory + setCurrentDirectory d + m `Exception.finally` setCurrentDirectory old diff --git a/README b/README --- a/README +++ b/README @@ -1,38 +1,129 @@ -== cabal install == +The cabal-install package +========================= -The automatic package manager for Haskell! +[Cabal home page](http://www.haskell.org/cabal/) -Intended usage: +The `cabal-install` package provides a command line tool called `cabal`. The +tool uses the `Cabal` library and provides a convenient user interface to the +Cabal/Hackage package build and distribution system. It can build and install +both local and remote packages, including dependencies. - cabal install xmonad -Just works. Defaults make sense. +Installation instructions for the cabal-install command line tool +================================================================= -It also has all the other commands that runhaskell Setup.hs supports. Eg +The `cabal-install` package requires a number of other packages, most of which +come with a standard ghc installation. It requires the `network` package, which +is sometimes packaged separately by Linux distributions, for example on +debian or ubuntu it is in "libghc6-network-dev". - cabal configure - cabal build - cabal install - cabal haddock - cabal sdist - cabal clean +It requires three other Haskell packages that are not always installed: -See cabal --help for the full list. + * Cabal (1.4 or later) + * HTTP + * zlib -There are also these extra commands: +All of these are available from [Hackage](http://hackage.haskell.org). - cabal update Updates the packages list from the hackage server - cabal list [pkgs] List packages with the given search terms in their name - cabal upgrade [pkgs] Like install but also upgrade all dependencies - cabal upgrade Upgrade all installed packages - cabal upload [tar] Upload a package tarball to the hackage server - cabal check Check the package for common mistakes +In future, cabal-install will be part of the Haskell Platform so will not need +to be installed separately. In the mean time however you have to install it +manually. Since it is just an ordinary Cabal package it can be built in the +standard way, but to make it a bit easier we have partly automated the process: -== Dependences == -Dependencies on standard libs: - base >= 2.1, process, directory, pretty, bytestring >= 0.9 - network, filepath >= 1.0, Cabal >=1.3.11 && <1.5 +Quickstart on Unix systems +-------------------------- -Dependencies on other libs: - zlib >= 0.4, HTTP >= 3000.0 && < 3001.2 +As a convenience for users on Unix systems there is a bootstrap.sh script which +will download and install each of the dependencies in turn. + + $ ./bootstrap.sh + +It will download and install the above three dependencies. The script will +install the library packages into `$HOME/.cabal/` and the `cabal` program will +be installed into `$HOME/.cabal/bin/`. + +You then have two choices: + + * put `$HOME/.cabal/bin` on your `$PATH` + * move the `cabal` program elsewhere and edit the `$HOME/.cabal/config` file + and set the `symlink-bindir` entry to point to an alternative location where + that is on your `$PATH`, eg a `$HOME/bin` directory. + + +Quickstart on Windows systems +----------------------------- + +For Windows users we hope to provide a pre-compiled `cabal.exe` program shortly. +In the mean time you have to build the three dependencies in [the standard way]. + +[the standard way]: + http://haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package + + +Using cabal-install +=================== + +There are two sets of commands: commands for working with a local project build +tree and ones for working with distributed released packages from hackage. + +For a list of the full set of commands and the flags for each command see + + $ cabal --help + + +Commands for developers for local build trees +--------------------------------------------- + +The commands for local project build trees are almost exactly the same as the +`runghc Setup` command line interface that many people are already familiar +with. In particular there are the commands + + cabal configure + cabal build + cabal haddock + cabal clean + cabal sdist + +The `install` command is somewhat different. It is an all-in-one operation. If +you run + + $ cabal install + +in your build tree it will configure, build and install. It takes all the flags +that `configure` takes such as `--global` and `--prefix`. + +In addition, if any dependencies are not installed it will download and install +them. If can also rebuild packages to ensure a consistent set of dependencies. + + +Commands for released hackage packages +-------------------------------------- + + $ cabal update + +This command gets the latest list of packages from the hackage server. +Currently this command has to be run manually occasionally, in particular if +you want to install a newly released package. + + + $ cabal install xmonad + +This is the eponymous command. It installs one or more named packages (and all +their dependencies) from hackage. + +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 + +This does a search of the installed and available packages. It does a +case-insensitive substring match on the package name. diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -6,8 +6,8 @@ # HTTP packages. It then installs cabal-install itself. # It expects to be run inside the cabal-install directory. -CABAL_VER="1.4.0.2" -HTTP_VER="3001.0.4" +CABAL_VER="1.6.0.1" +HTTP_VER="3001.1.3" ZLIB_VER="0.4.0.4" HACKAGE_URL="http://hackage.haskell.org/packages/archive" @@ -15,26 +15,46 @@ HTTP_URL=${HACKAGE_URL}/HTTP/${HTTP_VER}/HTTP-${HTTP_VER}.tar.gz ZLIB_URL=${HACKAGE_URL}/zlib/${ZLIB_VER}/zlib-${ZLIB_VER}.tar.gz -wget ${CABAL_URL} ${HTTP_URL} ${ZLIB_URL} +case `which wget curl` in + *curl) + curl -O ${CABAL_URL} -O ${HTTP_URL} -O ${ZLIB_URL} + ;; + *wget) + wget -c ${CABAL_URL} ${HTTP_URL} ${ZLIB_URL} + ;; + *) + echo "Failed to find a downloader. 'wget' or 'curl' is required." >&2 + exit 2 + ;; +esac tar -zxf Cabal-${CABAL_VER}.tar.gz -pushd Cabal-${CABAL_VER} +cd Cabal-${CABAL_VER} ghc --make Setup ./Setup configure --user && ./Setup build && ./Setup install -popd +cd .. tar -zxf HTTP-${HTTP_VER}.tar.gz -pushd HTTP-${HTTP_VER} +cd HTTP-${HTTP_VER} runghc Setup configure --user && runghc Setup build && runghc Setup install -popd +cd .. tar -zxf zlib-${ZLIB_VER}.tar.gz -pushd zlib-${ZLIB_VER} +cd zlib-${ZLIB_VER} runghc Setup configure --user && runghc Setup build && runghc Setup install -popd +cd .. runghc Setup configure --user && runghc Setup build && runghc Setup install +CABAL_BIN="$HOME/.cabal/bin" echo -echo "If all went well then 'cabal' is in $HOME/.cabal/bin/" -echo "You may want to add this dir to your PATH" + +if [ -x "$CABAL_BIN/cabal" ] +then + echo "cabal successfully installed in $CABAL_BIN." + echo "You may want to add $CABAL_BIN to your PATH." +else + echo "Sorry, something went wrong." +fi + +echo diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,5 +1,5 @@ Name: cabal-install -Version: 0.5.2 +Version: 0.6.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -22,7 +22,7 @@ Category: Distribution Build-type: Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh -Cabal-Version: >= 1.2 +Cabal-Version: >= 1.4 flag old-base description: Old, monolithic base @@ -63,12 +63,13 @@ Distribution.Client.Upload Distribution.Client.Utils Distribution.Client.Win32SelfUpgrade + Paths_cabal_install - build-depends: Cabal >= 1.4 && < 1.5, + build-depends: Cabal >= 1.6 && < 1.7, filepath >= 1.0, network >= 1 && < 3, HTTP >= 3000 && < 3002, - zlib >= 0.4 + zlib >= 0.4 && < 0.6 if flag(old-base) build-depends: base < 3 @@ -78,8 +79,8 @@ directory >= 1 && < 1.1, pretty >= 1 && < 1.1, random >= 1 && < 1.1, - containers >= 0.1 && < 0.2, - array >= 0.1 && < 0.2, + containers >= 0.1 && < 0.3, + array >= 0.1 && < 0.3, old-time >= 1 && < 1.1 if flag(bytestring-in-base) @@ -91,5 +92,5 @@ build-depends: Win32 >= 2 && < 3 cpp-options: -DWIN32 else - build-depends: unix >= 2.2 && < 2.4 + build-depends: unix >= 2.0 && < 2.4 extensions: CPP