cabal-install 0.5.2 → 0.6.0
raw patch · 20 files changed
+877/−425 lines, 20 filesdep ~Cabaldep ~arraydep ~containers
Dependency ranges changed: Cabal, array, containers, unix, zlib
Files
- Distribution/Client/BuildReports/Anonymous.hs +10/−6
- Distribution/Client/Check.hs +8/−4
- Distribution/Client/Dependency.hs +55/−25
- Distribution/Client/Dependency/TopDown.hs +149/−83
- Distribution/Client/Dependency/TopDown/Constraints.hs +78/−51
- Distribution/Client/Dependency/TopDown/Types.hs +5/−1
- Distribution/Client/Dependency/Types.hs +28/−6
- Distribution/Client/Fetch.hs +13/−9
- Distribution/Client/IndexUtils.hs +135/−53
- Distribution/Client/Install.hs +118/−53
- Distribution/Client/InstallPlan.hs +15/−17
- Distribution/Client/List.hs +8/−6
- Distribution/Client/SetupWrapper.hs +20/−48
- Distribution/Client/SrcDist.hs +13/−8
- Distribution/Client/Tar.hs +7/−7
- Distribution/Client/Types.hs +15/−2
- Distribution/Client/Utils.hs +44/−2
- README +117/−26
- bootstrap.sh +31/−11
- cabal-install.cabal +8/−7
Distribution/Client/BuildReports/Anonymous.hs view
@@ -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
Distribution/Client/Check.hs view
@@ -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
Distribution/Client/Dependency.hs view
@@ -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.
Distribution/Client/Dependency/TopDown.hs view
@@ -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 -- ------------------------------------------------------------
Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -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 ]
Distribution/Client/Dependency/TopDown/Types.hs view
@@ -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
Distribution/Client/Dependency/Types.hs view
@@ -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
Distribution/Client/Fetch.hs view
@@ -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 =
Distribution/Client/IndexUtils.hs view
@@ -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)))
Distribution/Client/Install.hs view
@@ -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
Distribution/Client/InstallPlan.hs view
@@ -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 "
Distribution/Client/List.hs view
@@ -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)
Distribution/Client/SetupWrapper.hs view
@@ -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
Distribution/Client/SrcDist.hs view
@@ -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
Distribution/Client/Tar.hs view
@@ -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
Distribution/Client/Types.hs view
@@ -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
Distribution/Client/Utils.hs view
@@ -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
README view
@@ -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.
bootstrap.sh view
@@ -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
cabal-install.cabal view
@@ -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