cabal-install 0.14.0 → 0.14.1
raw patch · 24 files changed
+449/−243 lines, 24 filesnew-uploader
Files
- Distribution/Client/Configure.hs +2/−1
- Distribution/Client/Dependency/Modular/Assignment.hs +8/−0
- Distribution/Client/Dependency/Modular/Builder.hs +3/−3
- Distribution/Client/Dependency/Modular/Dependency.hs +2/−2
- Distribution/Client/Dependency/Modular/Explore.hs +12/−12
- Distribution/Client/Dependency/Modular/Flag.hs +5/−3
- Distribution/Client/Dependency/Modular/Index.hs +1/−1
- Distribution/Client/Dependency/Modular/IndexConversion.hs +9/−9
- Distribution/Client/Dependency/Modular/Log.hs +20/−8
- Distribution/Client/Dependency/Modular/Message.hs +1/−0
- Distribution/Client/Dependency/Modular/Preference.hs +26/−9
- Distribution/Client/Dependency/Modular/Solver.hs +4/−2
- Distribution/Client/Dependency/Modular/Tree.hs +57/−56
- Distribution/Client/Dependency/Modular/Validate.hs +4/−4
- Distribution/Client/HttpUtils.hs +6/−6
- Distribution/Client/IndexUtils.hs +7/−6
- Distribution/Client/Install.hs +110/−52
- Distribution/Client/InstallPlan.hs +42/−16
- Distribution/Client/JobControl.hs +79/−0
- Distribution/Client/Setup.hs +16/−5
- Distribution/Client/SetupWrapper.hs +22/−19
- Distribution/Client/Tar.hs +2/−2
- Distribution/Client/Upload.hs +5/−22
- cabal-install.cabal +6/−5
Distribution/Client/Configure.hs view
@@ -104,7 +104,8 @@ (useDistPref defaultSetupScriptOptions) (configDistPref configFlags), useLoggingHandle = Nothing,- useWorkingDir = Nothing+ useWorkingDir = Nothing,+ forceExternalSetupMethod = False } where -- Hack: we typically want to allow the UserPackageDB for finding the
Distribution/Client/Dependency/Modular/Assignment.hs view
@@ -41,6 +41,14 @@ -- | Extend a package preassignment. --+-- Takes the variable that causes the new constraints, a current preassignment+-- and a set of new dependency constraints.+--+-- We're trying to extend the preassignment with each dependency one by one.+-- Each dependency is for a particular variable. We check if we already have+-- constraints for that variable in the current preassignment. If so, we're+-- trying to merge the constraints.+-- -- Either returns a witness of the conflict that would arise during the merge, -- or the successfully extended assignment. extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
Distribution/Client/Dependency/Modular/Builder.hs view
@@ -63,7 +63,7 @@ -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagDefaults ->+scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagInfo -> BuildState -> BuildState scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s where@@ -104,8 +104,8 @@ -- that is indicated by the flag default. -- -- TODO: Should we include the flag default in the tree?- go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) b t f) gr) }) =- FChoiceF qfn (gr, sc) trivial (P.fromList (reorder b+ go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m) t f) gr) }) =+ FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }), (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])) where
Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -95,8 +95,8 @@ -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. data FlaggedDep qpn =- Flagged (FN qpn) FDefault (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)- | Stanza (SN qpn) (TrueFlaggedDeps qpn)+ Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)+ | Stanza (SN qpn) (TrueFlaggedDeps qpn) | Simple (Dep qpn) deriving (Eq, Show)
Distribution/Client/Dependency/Modular/Explore.hs view
@@ -24,16 +24,16 @@ where go (FailF c fr) = (Just c, Fail c fr) go (DoneF rdm ) = (Nothing, Done rdm)- go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts'))+ go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts')) where ~(c, ts') = combine (P qpn) (P.toList ts) S.empty- go (FChoiceF qfn _ b ts) = (c, FChoice qfn c b (P.fromList ts'))+ go (FChoiceF qfn _ b m ts) = (c, FChoice qfn c b m (P.fromList ts')) where ~(c, ts') = combine (F qfn) (P.toList ts) S.empty- go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts'))+ go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts')) where ~(c, ts') = combine (S qsn) (P.toList ts) S.empty- go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts'))+ go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts')) where ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts c = case cs of [] -> Nothing@@ -77,22 +77,22 @@ where go (FailF _ _) _ = A.empty go (DoneF rdm) a = pure (a, rdm)- go (PChoiceF qpn _ ts) (A pa fa sa) =+ go (PChoiceF qpn _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice ts- go (FChoiceF qfn _ _ ts) (A pa fa sa) =+ go (FChoiceF qfn _ _ _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice ts- go (SChoiceF qsn _ _ ts) (A pa fa sa) =+ go (SChoiceF qsn _ _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice ts- go (GoalChoiceF ts) a =+ go (GoalChoiceF ts) a = casePSQ ts A.empty -- empty goal choice is an internal error (\ _k v _xs -> v a) -- commit to the first goal choice @@ -102,28 +102,28 @@ where go (FailF c fr) _ = failWith (Failure c fr) go (DoneF rdm) a = succeedWith Success (a, rdm)- go (PChoiceF qpn c ts) (A pa fa sa) =+ go (PChoiceF qpn c ts) (A pa fa sa) = backjumpInfo c $ asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> tryWith (TryP (PI qpn k)) $ -- log and ... r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice ts- go (FChoiceF qfn c _ ts) (A pa fa sa) =+ go (FChoiceF qfn c _ _ ts) (A pa fa sa) = backjumpInfo c $ asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> tryWith (TryF qfn k) $ -- log and ... r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice ts- go (SChoiceF qsn c _ ts) (A pa fa sa) =+ go (SChoiceF qsn c _ ts) (A pa fa sa) = backjumpInfo c $ asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> tryWith (TryS qsn k) $ -- log and ... r (A pa fa (M.insert qsn k sa))) -- record the pkg choice ts- go (GoalChoiceF ts) a =+ go (GoalChoiceF ts) a = casePSQ ts (failWith (Failure S.empty EmptyGoalChoice)) -- empty goal choice is an internal error (\ k v _xs -> continueWith (Next (close k)) (v a)) -- commit to the first goal choice
Distribution/Client/Dependency/Modular/Flag.hs view
@@ -25,11 +25,13 @@ unFlag :: Flag -> String unFlag (FlagName fn) = fn --- | Flag default. Just a bool.-type FDefault = Bool+-- | Flag info. Default value, and whether the flag is manual.+-- Manual flags can only be set explicitly.+data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool }+ deriving (Eq, Ord, Show) -- | Flag defaults.-type FlagDefaults = Map Flag FDefault+type FlagInfo = Map Flag FInfo -- | Qualified flag name. type QFN = FN QPN
Distribution/Client/Dependency/Modular/Index.hs view
@@ -20,7 +20,7 @@ -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken.-data PInfo = PInfo (FlaggedDeps PN) FlagDefaults Encaps (Maybe FailReason)+data PInfo = PInfo (FlaggedDeps PN) FlagInfo Encaps (Maybe FailReason) deriving (Show) -- | Encapsulations. A list of package names.
Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -110,29 +110,29 @@ convGPD os arch cid pi (GenericPackageDescription _ flags libs exes tests benchs) = let- fds = flagDefaults flags+ fds = flagInfo flags in PInfo (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++ concatMap (convCondTree os arch cid pi fds (const True) . snd) exes ++ (prefix (Stanza (SN pi TestStanzas))- (concatMap (convCondTree os arch cid pi fds (const True) . snd) tests)) +++ (L.map (convCondTree os arch cid pi fds (const True) . snd) tests)) ++ (prefix (Stanza (SN pi BenchStanzas))- (concatMap (convCondTree os arch cid pi fds (const True) . snd) benchs)))+ (L.map (convCondTree os arch cid pi fds (const True) . snd) benchs))) fds [] -- TODO: add encaps Nothing -prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> FlaggedDeps qpn -> FlaggedDeps qpn+prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn prefix _ [] = []-prefix f fds = [f fds]+prefix f fds = [f (concat fds)] -- | Convert flag information.-flagDefaults :: [PD.Flag] -> FlagDefaults-flagDefaults = M.fromList . L.map (\ (MkFlag fn _ b _) -> (fn, b))+flagInfo :: [PD.Flag] -> FlagInfo+flagInfo = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m)) -- | Convert condition trees to flagged dependencies.-convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagDefaults ->+convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo -> (a -> Bool) -> -- how to detect if a branch is active CondTree ConfVar [Dependency] a -> FlaggedDeps PN convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches)@@ -149,7 +149,7 @@ -- special flags and subsequently simplify to a tree that only depends on -- simple flag choices. convBranch :: OS -> Arch -> CompilerId ->- PI PN -> FlagDefaults ->+ PI PN -> FlagInfo -> (a -> Bool) -> -- how to detect if a branch is active (Condition ConfVar, CondTree ConfVar [Dependency] a,
Distribution/Client/Dependency/Modular/Log.hs view
@@ -34,18 +34,21 @@ (ms, s) = runLog l (es, e) = proc 0 ms -- catch first error (always) (ns, t) = case mbj of- Nothing -> (ms, Nothing)- Just n -> proc n ms+ Nothing -> (ms, Nothing)+ Just n -> proc n ms -- prefer first error over later error r = case t of Nothing -> case s of Nothing -> e Just _ -> Nothing Just _ -> e- in go es -- trace for first error+ in go es es -- trace for first error (showMessages (const True) True ns) -- shortened run r s where+ -- Proc takes the allowed number of backjumps and a list of messages and explores the+ -- message list until the maximum number of backjumps has been reached. The log until+ -- that point as well as whether we have encountered an error or not are returned. proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN)) proc _ [] = ([], Nothing) proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _))@@ -54,15 +57,24 @@ proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs) proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs) + -- This function takes a lot of arguments. The first two are both supposed to be+ -- the log up to the first error. That's the error that will always be printed in+ -- case we do not find a solution. We pass this log twice, because we evaluate it+ -- in parallel with the full log, but we also want to retain the reference to its+ -- beginning for when we print it. This trick prevents a space leak!+ --+ -- The thirs argument is the full log, the fifth and six error conditions.+ -- -- The order of arguments is important! In particular 's' must not be evaluated -- unless absolutely necessary. It contains the final result, and if we shortcut -- with an error due to backjumping, evaluating 's' would still require traversing -- the entire tree.- go ms (x : xs) r s = Step x (go ms xs r s)- go ms [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" ++- unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))- go _ [] _ (Just s) = Done s- go _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen+ go ms (_ : ns) (x : xs) r s = Step x (go ms ns xs r s)+ go ms [] (x : xs) r s = Step x (go ms [] xs r s)+ go ms _ [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" +++ unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))+ go _ _ [] _ (Just s) = Done s+ go _ _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen logToProgress' :: Log Message a -> Progress String String a logToProgress' l = let
Distribution/Client/Dependency/Modular/Message.hs view
@@ -87,6 +87,7 @@ showFR _ GlobalConstraintInstalled = " (global constraint requires installed instance)" showFR _ GlobalConstraintSource = " (global constraint requires source instance)" showFR _ GlobalConstraintFlag = " (global constraint requires opposite flag selection)"+showFR _ ManualFlag = " (manual flag can only be changed explicitly)" showFR _ (BuildFailureNotInIndex pn) = " (unknown package: " ++ display pn ++ ")" showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")" -- The following are internal failures. They should not occur. In the
Distribution/Client/Dependency/Modular/Preference.hs view
@@ -108,26 +108,43 @@ enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons enforcePackageConstraints pcs = trav go where- go (PChoiceF qpn@(Q _ pn) gr ts) =+ go (PChoiceF qpn@(Q _ pn) gr ts) = let c = toConflictSet (Goal (P qpn) gr) -- compose the transformation functions for each of the relevant constraint g = \ i -> foldl (\ h pc -> h . processPackageConstraintP c i pc) id (M.findWithDefault [] pn pcs)- in PChoiceF qpn gr (P.mapWithKey g ts)- go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr ts) =+ in PChoiceF qpn gr (P.mapWithKey g ts)+ go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) = let c = toConflictSet (Goal (F qfn) gr) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id (M.findWithDefault [] pn pcs)- in FChoiceF qfn gr tr (P.mapWithKey g ts)- go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =+ in FChoiceF qfn gr tr m (P.mapWithKey g ts)+ go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = let c = toConflictSet (Goal (S qsn) gr) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id (M.findWithDefault [] pn pcs)- in SChoiceF qsn gr tr (P.mapWithKey g ts)+ in SChoiceF qsn gr tr (P.mapWithKey g ts) go x = x +-- | Transformation that tries to enforce manual flags. Manual flags+-- can only be re-set explicitly by the user. This transformation should+-- be run after user preferences have been enforced. For manual flags,+-- it disables all but the first non-disabled choice.+enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons+enforceManualFlags = trav go+ where+ go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $+ let c = toConflictSet (Goal (F qfn) gr)+ in case span isDisabled (P.toList ts) of+ (_ , []) -> P.fromList []+ (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)+ where+ isDisabled (_, Fail _ _) = True+ isDisabled _ = False+ go x = x+ -- | Prefer installed packages over non-installed packages, generally. -- All installed packages or non-installed packages are treated as -- equivalent.@@ -232,9 +249,9 @@ go x = x defer :: Tree a -> Tree a -> Ordering- defer (FChoice _ _ True _) _ = GT- defer _ (FChoice _ _ True _) = LT- defer _ _ = EQ+ defer (FChoice _ _ True _ _) _ = GT+ defer _ (FChoice _ _ True _ _) = LT+ defer _ _ = EQ -- | Variant of 'preferEasyGoalChoices'. --
Distribution/Client/Dependency/Modular/Solver.hs view
@@ -39,11 +39,13 @@ buildPhase where explorePhase = exploreTreeLog . backjump- heuristicsPhase = if preferEasyGoalChoices sc+ heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)+ if preferEasyGoalChoices sc then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices else P.preferBaseGoalChoice preferencesPhase = P.preferPackagePreferences userPrefs- validationPhase = P.enforcePackageConstraints userConstraints .+ validationPhase = P.enforceManualFlags . -- can only be done after user constraints+ P.enforcePackageConstraints userConstraints . validateTree idx prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) . -- packages that can never be "upgraded":
Distribution/Client/Dependency/Modular/Tree.hs view
@@ -14,10 +14,10 @@ -- | Type of the search tree. Inlining the choice nodes for now. data Tree a =- PChoice QPN a (PSQ I (Tree a))- | FChoice QFN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial- | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial- | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty+ PChoice QPN a (PSQ I (Tree a))+ | FChoice QFN a Bool Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial, second Bool whether it's manual+ | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial+ | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty | Done RevDepMap | Fail (ConflictSet QPN) FailReason deriving (Eq, Show)@@ -26,12 +26,12 @@ -- dependencies introduced by this node. instance Functor Tree where- fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)- fmap f (FChoice qfn i b xs) = FChoice qfn (f i) b (fmap (fmap f) xs)- fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)- fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)- fmap _f (Done rdm ) = Done rdm- fmap _f (Fail cs fr ) = Fail cs fr+ fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)+ fmap f (FChoice qfn i b m xs) = FChoice qfn (f i) b m (fmap (fmap f) xs)+ fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)+ fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)+ fmap _f (Done rdm ) = Done rdm+ fmap _f (Fail cs fr ) = Fail cs fr data FailReason = InconsistentInitialConstraints | Conflicting [Dep QPN]@@ -43,6 +43,7 @@ | GlobalConstraintInstalled | GlobalConstraintSource | GlobalConstraintFlag+ | ManualFlag | BuildFailureNotInIndex PN | MalformedFlagChoice QFN | MalformedStanzaChoice QSN@@ -52,52 +53,52 @@ -- | Functor for the tree type. data TreeF a b =- PChoiceF QPN a (PSQ I b)- | FChoiceF QFN a Bool (PSQ Bool b)- | SChoiceF QSN a Bool (PSQ Bool b)- | GoalChoiceF (PSQ OpenGoal b)+ PChoiceF QPN a (PSQ I b)+ | FChoiceF QFN a Bool Bool (PSQ Bool b)+ | SChoiceF QSN a Bool (PSQ Bool b)+ | GoalChoiceF (PSQ OpenGoal b) | DoneF RevDepMap | FailF (ConflictSet QPN) FailReason out :: Tree a -> TreeF a (Tree a)-out (PChoice p i ts) = PChoiceF p i ts-out (FChoice p i b ts) = FChoiceF p i b ts-out (SChoice p i b ts) = SChoiceF p i b ts-out (GoalChoice ts) = GoalChoiceF ts-out (Done x ) = DoneF x-out (Fail c x ) = FailF c x+out (PChoice p i ts) = PChoiceF p i ts+out (FChoice p i b m ts) = FChoiceF p i b m ts+out (SChoice p i b ts) = SChoiceF p i b ts+out (GoalChoice ts) = GoalChoiceF ts+out (Done x ) = DoneF x+out (Fail c x ) = FailF c x inn :: TreeF a (Tree a) -> Tree a-inn (PChoiceF p i ts) = PChoice p i ts-inn (FChoiceF p i b ts) = FChoice p i b ts-inn (SChoiceF p i b ts) = SChoice p i b ts-inn (GoalChoiceF ts) = GoalChoice ts-inn (DoneF x ) = Done x-inn (FailF c x ) = Fail c x+inn (PChoiceF p i ts) = PChoice p i ts+inn (FChoiceF p i b m ts) = FChoice p i b m ts+inn (SChoiceF p i b ts) = SChoice p i b ts+inn (GoalChoiceF ts) = GoalChoice ts+inn (DoneF x ) = Done x+inn (FailF c x ) = Fail c x instance Functor (TreeF a) where- fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)- fmap f (FChoiceF p i b ts) = FChoiceF p i b (fmap f ts)- fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)- fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)- fmap _ (DoneF x ) = DoneF x- fmap _ (FailF c x ) = FailF c x+ fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)+ fmap f (FChoiceF p i b m ts) = FChoiceF p i b m (fmap f ts)+ fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)+ fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)+ fmap _ (DoneF x ) = DoneF x+ fmap _ (FailF c x ) = FailF c x instance Foldable (TreeF a) where- foldr op e (PChoiceF _ _ ts) = foldr op e ts- foldr op e (FChoiceF _ _ _ ts) = foldr op e ts- foldr op e (SChoiceF _ _ _ ts) = foldr op e ts- foldr op e (GoalChoiceF ts) = foldr op e ts- foldr _ e (DoneF _ ) = e- foldr _ e (FailF _ _ ) = e+ foldr op e (PChoiceF _ _ ts) = foldr op e ts+ foldr op e (FChoiceF _ _ _ _ ts) = foldr op e ts+ foldr op e (SChoiceF _ _ _ ts) = foldr op e ts+ foldr op e (GoalChoiceF ts) = foldr op e ts+ foldr _ e (DoneF _ ) = e+ foldr _ e (FailF _ _ ) = e instance Traversable (TreeF a) where- traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts- traverse f (FChoiceF p i b ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts- traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts- traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts- traverse _ (DoneF x ) = DoneF <$> pure x- traverse _ (FailF c x ) = FailF <$> pure c <*> pure x+ traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts+ traverse f (FChoiceF p i b m ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> pure m <*> traverse f ts+ traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts+ traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts+ traverse _ (DoneF x ) = DoneF <$> pure x+ traverse _ (FailF c x ) = FailF <$> pure c <*> pure x -- | Determines whether a tree is active, i.e., isn't a failure node. active :: Tree a -> Bool@@ -107,22 +108,22 @@ -- | Determines how many active choices are available in a node. Note that we -- count goal choices as having one choice, always. choices :: Tree a -> Int-choices (PChoice _ _ ts) = P.length (P.filter active ts)-choices (FChoice _ _ _ ts) = P.length (P.filter active ts)-choices (SChoice _ _ _ ts) = P.length (P.filter active ts)-choices (GoalChoice _ ) = 1-choices (Done _ ) = 1-choices (Fail _ _ ) = 0+choices (PChoice _ _ ts) = P.length (P.filter active ts)+choices (FChoice _ _ _ _ ts) = P.length (P.filter active ts)+choices (SChoice _ _ _ ts) = P.length (P.filter active ts)+choices (GoalChoice _ ) = 1+choices (Done _ ) = 1+choices (Fail _ _ ) = 0 -- | Variant of 'choices' that only approximates the number of choices, -- using 'llength'. lchoices :: Tree a -> Int-lchoices (PChoice _ _ ts) = P.llength (P.filter active ts)-lchoices (FChoice _ _ _ ts) = P.llength (P.filter active ts)-lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts)-lchoices (GoalChoice _ ) = 1-lchoices (Done _ ) = 1-lchoices (Fail _ _ ) = 0+lchoices (PChoice _ _ ts) = P.llength (P.filter active ts)+lchoices (FChoice _ _ _ _ ts) = P.llength (P.filter active ts)+lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts)+lchoices (GoalChoice _ ) = 1+lchoices (Done _ ) = 1+lchoices (Fail _ _ ) = 0 -- | Catamorphism on trees. cata :: (TreeF a b -> b) -> Tree a -> b
Distribution/Client/Dependency/Modular/Validate.hs view
@@ -85,8 +85,8 @@ where go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons) - go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)- go (FChoiceF qfn (gr, _sc) b ts) =+ go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)+ go (FChoiceF qfn (gr, _sc) b m ts) = do -- Flag choices may occur repeatedly (because they can introduce new constraints -- in various places). However, subsequent choices must be consistent. We thereby@@ -98,8 +98,8 @@ Just t -> goF qfn gr rb t Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn) Nothing -> -- flag choice is new, follow both branches- FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts)- go (SChoiceF qsn (gr, _sc) b ts) =+ FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts)+ go (SChoiceF qsn (gr, _sc) b ts) = do -- Optional stanza choices are very similar to flag choices. PA _ _ psa <- asks pa -- obtain current stanza-preassignment
Distribution/Client/HttpUtils.hs view
@@ -18,8 +18,8 @@ import Network.Stream ( Result, ConnError(..) ) import Network.Browser- ( Proxy (..), Authority (..), BrowserAction, browse- , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request)+ ( Proxy (..), Authority(..), BrowserAction, browse, setAllowBasicAuth, setAuthorityGen+ , setOutHandler, setErrHandler, setProxy, request) import Control.Monad ( mplus, join, liftM, liftM2 ) import qualified Data.ByteString.Lazy.Char8 as ByteString@@ -153,10 +153,10 @@ -- |Carry out a GET request, using the local proxy settings getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $- cabalBrowse verbosity (return ()) (request (mkRequest uri))+ cabalBrowse verbosity Nothing (request (mkRequest uri)) cabalBrowse :: Verbosity- -> BrowserAction s ()+ -> Maybe (String, String) -> BrowserAction s a -> IO a cabalBrowse verbosity auth act = do@@ -165,8 +165,8 @@ setProxy p setErrHandler (warn verbosity . ("http error: "++)) setOutHandler (debug verbosity)- auth- setAuthorityGen (\_ _ -> return Nothing)+ setAllowBasicAuth False+ setAuthorityGen (\_ _ -> return auth) act downloadURI :: Verbosity
Distribution/Client/IndexUtils.hs view
@@ -338,7 +338,7 @@ writeFile cacheFile (showIndexCache cache) where mkCache pkgs prefs =- [ CachePrefrence pref | pref <- prefs ]+ [ CachePreference pref | pref <- prefs ] ++ [ CachePackageId pkgid blockNo | (pkgid, _, blockNo) <- pkgs ] readPackageIndexCacheFile :: Package pkg@@ -376,7 +376,7 @@ let srcpkg = mkPkg pkgid pkg accum (srcpkg:srcpkgs) prefs entries - accum srcpkgs prefs (CachePrefrence pref : entries) =+ accum srcpkgs prefs (CachePreference pref : entries) = accum srcpkgs (pref:prefs) entries getPackageDescription blockno = do@@ -413,7 +413,7 @@ type BlockNo = Int data IndexCacheEntry = CachePackageId PackageId BlockNo- | CachePrefrence Dependency+ | CachePreference Dependency deriving (Eq, Show) readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry@@ -421,12 +421,13 @@ case BSS.words line of [key, pkgnamestr, pkgverstr, sep, blocknostr] | key == packageKey && sep == blocknoKey ->- case (parseName pkgnamestr, parseVer pkgverstr [], parseBlockNo blocknostr) of+ case (parseName pkgnamestr, parseVer pkgverstr [],+ parseBlockNo blocknostr) of (Just pkgname, Just pkgver, Just blockno) -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno) _ -> Nothing (key: remainder) | key == preferredVersionKey ->- fmap CachePrefrence (simpleParse (BSS.unpack (BSS.unwords remainder)))+ fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder))) _ -> Nothing where packageKey = BSS.pack "pkg:"@@ -456,7 +457,7 @@ CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid) ++ " " ++ display (packageVersion pkgid) ++ " b# " ++ show b- CachePrefrence dep -> "pref-ver: " ++ display dep+ CachePreference dep -> "pref-ver: " ++ display dep readIndexCache :: BSS.ByteString -> [IndexCacheEntry] readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines
Distribution/Client/Install.hs view
@@ -78,6 +78,7 @@ import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed import Paths_cabal_install (getBinDir)+import Distribution.Client.JobControl import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId), compilerFlavor@@ -99,7 +100,7 @@ ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package- ( PackageIdentifier, packageName, packageVersion+ ( PackageIdentifier, PackageId, packageName, packageVersion , Package(..), PackageFixedDeps(..) , Dependency(..), thisPackageVersion, InstalledPackageId ) import qualified Distribution.PackageDescription as PackageDescription@@ -409,16 +410,20 @@ linearizeInstallPlan :: PackageIndex -> InstallPlan -> [(ConfiguredPackage, PackageStatus)]-linearizeInstallPlan installedPkgIndex plan = unfoldr next plan+linearizeInstallPlan installedPkgIndex plan =+ unfoldr next plan where next plan' = case InstallPlan.ready plan' of [] -> Nothing- (pkg:_) -> Just ((pkg, status), InstallPlan.completed pkgid result plan')- where pkgid = packageId pkg- status = packageStatus installedPkgIndex pkg- result = BuildOk DocsNotTried TestsNotTried- --FIXME: This is a bit of a hack,- -- pretending that each package is installed+ (pkg:_) -> Just ((pkg, status), plan'')+ where+ pkgid = packageId pkg+ status = packageStatus installedPkgIndex pkg+ plan'' = InstallPlan.completed pkgid+ (BuildOk DocsNotTried TestsNotTried)+ (InstallPlan.processing [pkg] plan')+ --FIXME: This is a bit of a hack,+ -- pretending that each package is installed data PackageStatus = NewPackage | NewVersion [Version]@@ -737,12 +742,18 @@ globalFlags, configFlags, configExFlags, installFlags, haddockFlags) installedPkgIndex installPlan = do - executeInstallPlan installPlan $ \cpkg ->+ jobControl <- if parallelBuild then newParallelJobControl+ else newSerialJobControl+ buildLimit <- newJobLimit numJobs+ fetchLimit <- newJobLimit (min numJobs numFetchJobs)+ installLimit <- newJobLimit 1 --serialise installation++ executeInstallPlan verbosity jobControl installPlan $ \cpkg -> installConfiguredPackage platform compid configFlags cpkg $ \configFlags' src pkg ->- fetchSourcePackage verbosity src $ \src' ->- installLocalPackage verbosity (packageId pkg) src' $ \mpath ->- installUnpackedPackage verbosity+ fetchSourcePackage verbosity fetchLimit src $ \src' ->+ installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->+ installUnpackedPackage verbosity buildLimit installLimit (setupScriptOptions installedPkgIndex) miscOptions configFlags' installFlags haddockFlags compid pkg mpath useLogFile@@ -751,6 +762,10 @@ platform = InstallPlan.planPlatform installPlan compid = InstallPlan.planCompiler installPlan + numJobs = fromFlag (installNumJobs installFlags)+ numFetchJobs = 2+ parallelBuild = numJobs >= 2+ setupScriptOptions index = SetupScriptOptions { useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), useCompiler = Just comp,@@ -771,7 +786,8 @@ (useDistPref defaultSetupScriptOptions) (configDistPref configFlags), useLoggingHandle = Nothing,- useWorkingDir = Nothing+ useWorkingDir = Nothing,+ forceExternalSetupMethod = parallelBuild } reportingLevel = fromFlag (installBuildReports installFlags) logsDir = fromFlag (globalLogsDir globalFlags)@@ -784,6 +800,8 @@ = Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log" | otherwise = flagToMaybe (installLogFile installFlags)++ substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath substLogFileName template pkg = fromPathTemplate . substPathTemplate env $ template@@ -796,16 +814,39 @@ } -executeInstallPlan :: Monad m- => InstallPlan- -> (ConfiguredPackage -> m BuildResult)- -> m InstallPlan-executeInstallPlan plan installPkg = case InstallPlan.ready plan of- [] -> return plan- (pkg: _) -> do buildResult <- installPkg pkg- let plan' = updatePlan (packageId pkg) buildResult plan- executeInstallPlan plan' installPkg+executeInstallPlan :: Verbosity+ -> JobControl IO (PackageId, BuildResult)+ -> InstallPlan+ -> (ConfiguredPackage -> IO BuildResult)+ -> IO InstallPlan+executeInstallPlan verbosity jobCtl plan0 installPkg =+ tryNewTasks 0 plan0 where+ tryNewTasks taskCount plan = do+ case InstallPlan.ready plan of+ [] | taskCount == 0 -> return plan+ | otherwise -> waitForTasks taskCount plan+ pkgs -> do+ sequence_+ [ do notice verbosity $ "Ready to install " ++ display pkgid+ spawnJob jobCtl $ do+ buildResult <- installPkg pkg+ return (packageId pkg, buildResult)+ | pkg <- pkgs+ , let pkgid = packageId pkg]++ let taskCount' = taskCount + length pkgs+ plan' = InstallPlan.processing pkgs plan+ waitForTasks taskCount' plan'++ waitForTasks taskCount plan = do+ notice verbosity $ "Waiting for install task to finish..."+ (pkgid, buildResult) <- collectJob jobCtl+ notice verbosity $ "Collecting build result for " ++ display pkgid+ let taskCount' = taskCount-1+ plan' = updatePlan pkgid buildResult plan+ tryNewTasks taskCount' plan'+ updatePlan pkgid (Right buildSuccess) = InstallPlan.completed pkgid buildSuccess @@ -847,74 +888,91 @@ fetchSourcePackage :: Verbosity+ -> JobLimit -> PackageLocation (Maybe FilePath) -> (PackageLocation FilePath -> IO BuildResult) -> IO BuildResult-fetchSourcePackage verbosity src installPkg = do+fetchSourcePackage verbosity fetchLimit src installPkg = do fetched <- checkFetched src case fetched of Just src' -> installPkg src'- Nothing -> onFailure DownloadFailed $- fetchPackage verbosity src >>= installPkg+ Nothing -> onFailure DownloadFailed $ do+ loc <- withJobLimit fetchLimit $+ fetchPackage verbosity src+ installPkg loc installLocalPackage- :: Verbosity -> PackageIdentifier -> PackageLocation FilePath+ :: Verbosity+ -> JobLimit+ -> PackageIdentifier -> PackageLocation FilePath -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult-installLocalPackage verbosity pkgid location installPkg = case location of+installLocalPackage verbosity jobLimit pkgid location installPkg = + case location of+ LocalUnpackedPackage dir -> installPkg (Just dir) LocalTarballPackage tarballPath ->- installLocalTarballPackage verbosity pkgid tarballPath installPkg+ installLocalTarballPackage verbosity jobLimit+ pkgid tarballPath installPkg RemoteTarballPackage _ tarballPath ->- installLocalTarballPackage verbosity pkgid tarballPath installPkg+ installLocalTarballPackage verbosity jobLimit+ pkgid tarballPath installPkg RepoTarballPackage _ _ tarballPath ->- installLocalTarballPackage verbosity pkgid tarballPath installPkg+ installLocalTarballPackage verbosity jobLimit+ pkgid tarballPath installPkg installLocalTarballPackage- :: Verbosity -> PackageIdentifier -> FilePath+ :: Verbosity+ -> JobLimit+ -> PackageIdentifier -> FilePath -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult-installLocalTarballPackage verbosity pkgid tarballPath installPkg = do+installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do tmp <- getTemporaryDirectory withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> onFailure UnpackFailed $ do- info verbosity $ "Extracting " ++ tarballPath- ++ " to " ++ tmpDirPath ++ "..." let relUnpackedPath = display pkgid absUnpackedPath = tmpDirPath </> relUnpackedPath descFilePath = absUnpackedPath </> display (packageName pkgid) <.> "cabal"- extractTarGzFile tmpDirPath relUnpackedPath tarballPath- exists <- doesFileExist descFilePath- when (not exists) $- die $ "Package .cabal file not found: " ++ show descFilePath+ withJobLimit jobLimit $ do+ info verbosity $ "Extracting " ++ tarballPath+ ++ " to " ++ tmpDirPath ++ "..."+ extractTarGzFile tmpDirPath relUnpackedPath tarballPath+ exists <- doesFileExist descFilePath+ when (not exists) $+ die $ "Package .cabal file not found: " ++ show descFilePath installPkg (Just absUnpackedPath) -installUnpackedPackage :: Verbosity- -> SetupScriptOptions- -> InstallMisc- -> ConfigFlags- -> InstallFlags- -> HaddockFlags- -> CompilerId- -> PackageDescription- -> Maybe FilePath -- ^ Directory to change to before starting the installation.- -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)- -> IO BuildResult-installUnpackedPackage verbosity scriptOptions miscOptions+installUnpackedPackage+ :: Verbosity+ -> JobLimit+ -> JobLimit+ -> SetupScriptOptions+ -> InstallMisc+ -> ConfigFlags+ -> InstallFlags+ -> HaddockFlags+ -> CompilerId+ -> PackageDescription+ -> Maybe FilePath -- ^ Directory to change to before starting the installation.+ -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)+ -> IO BuildResult+installUnpackedPackage verbosity buildLimit installLimit+ scriptOptions miscOptions configFlags installConfigFlags haddockFlags compid pkg workingDir useLogFile = -- Configure phase- onFailure ConfigureFailed $ do+ onFailure ConfigureFailed $ withJobLimit buildLimit $ do setup configureCommand configureFlags -- Build phase@@ -938,7 +996,7 @@ | otherwise = TestsNotTried -- Install phase- onFailure InstallFailed $+ onFailure InstallFailed $ withJobLimit installLimit $ withWin32SelfUpgrade verbosity configFlags compid pkg $ do case rootCmd miscOptions of (Just cmd) -> reexec cmd
Distribution/Client/InstallPlan.hs view
@@ -20,6 +20,7 @@ new, toList, ready,+ processing, completed, failed, remove,@@ -28,7 +29,7 @@ planPlatform, planCompiler, - -- * Checking valididy of plans+ -- * Checking validity of plans valid, closed, consistent,@@ -120,24 +121,27 @@ -- Note that plans do not necessarily compose. You might have a valid plan for -- package A and a valid plan for package B. That does not mean the composition--- is simultaniously valid for A and B. In particular you're most likely to+-- is simultaneously valid for A and B. In particular you're most likely to -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. data PlanPackage = PreExisting InstalledPackage | Configured ConfiguredPackage+ | Processing ConfiguredPackage | Installed ConfiguredPackage BuildSuccess | Failed ConfiguredPackage BuildFailure instance Package PlanPackage where packageId (PreExisting pkg) = packageId pkg packageId (Configured pkg) = packageId pkg+ packageId (Processing pkg) = packageId pkg packageId (Installed pkg _) = packageId pkg packageId (Failed pkg _) = packageId pkg instance PackageFixedDeps PlanPackage where depends (PreExisting pkg) = depends pkg depends (Configured pkg) = depends pkg+ depends (Processing pkg) = depends pkg depends (Installed pkg _) = depends pkg depends (Failed pkg _) = depends pkg @@ -203,13 +207,16 @@ ready :: InstallPlan -> [ConfiguredPackage] ready plan = assert check readyPackages where- check = if null readyPackages then null configuredPackages else True- configuredPackages =- [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]+ check = if null readyPackages && null processingPackages+ then null configuredPackages+ else True+ configuredPackages = [ pkg | Configured pkg <- toList plan ]+ processingPackages = [ pkg | Processing pkg <- toList plan] readyPackages = filter (all isInstalled . depends) configuredPackages isInstalled pkg = case PackageIndex.lookupPackageId (planIndex plan) pkg of Just (Configured _) -> False+ Just (Processing _) -> False Just (Failed _ _) -> internalError depOnFailed Just (PreExisting _) -> True Just (Installed _ _) -> True@@ -217,10 +224,22 @@ incomplete = "install plan is not closed" depOnFailed = "configured package depends on failed package" +-- | Marks packages in the graph as currently processing (e.g. building).+--+-- * The package must exist in the graph and be in the configured state.+--+processing :: [ConfiguredPackage] -> InstallPlan -> InstallPlan+processing pkgs plan = assert (invariant plan') plan'+ where+ plan' = plan {+ planIndex = PackageIndex.merge (planIndex plan) processingPkgs+ }+ processingPkgs = PackageIndex.fromList [Processing pkg | pkg <- pkgs]+ -- | Marks a package in the graph as completed. Also saves the build result for -- the completed package in the plan. ----- * The package must exist in the graph.+-- * The package must exist in the graph and be in the processing state. -- * The package must have had no uninstalled dependent packages. -- completed :: PackageIdentifier@@ -231,12 +250,13 @@ plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) }- installed = Installed (lookupConfiguredPackage plan pkgid) buildResult+ installed = Installed (lookupProcessingPackage plan pkgid) buildResult -- | Marks a package in the graph as having failed. It also marks all the -- packages that depended on it as having failed. ----- * The package must exist in the graph and be in the configured state.+-- * The package must exist in the graph and be in the processing+-- state. -- failed :: PackageIdentifier -- ^ The id of the package that failed to install -> BuildFailure -- ^ The build result to use for the failed package@@ -248,14 +268,14 @@ plan' = plan { planIndex = PackageIndex.merge (planIndex plan) failures }- pkg = lookupConfiguredPackage plan pkgid+ pkg = lookupProcessingPackage plan pkgid failures = PackageIndex.fromList $ Failed pkg buildResult : [ Failed pkg' buildResult' | Just pkg' <- map checkConfiguredPackage $ packagesThatDependOn plan pkgid ] --- | lookup the reachable packages in the reverse dependency graph+-- | Lookup the reachable packages in the reverse dependency graph. -- packagesThatDependOn :: InstallPlan -> PackageIdentifier -> [PlanPackage]@@ -264,16 +284,16 @@ . Graph.reachable (planGraphRev plan) . planVertexOf plan --- | lookup a package that we expect to be in the configured state+-- | Lookup a package that we expect to be in the processing state. ---lookupConfiguredPackage :: InstallPlan+lookupProcessingPackage :: InstallPlan -> PackageIdentifier -> ConfiguredPackage-lookupConfiguredPackage plan pkgid =+lookupProcessingPackage plan pkgid = case PackageIndex.lookupPackageId (planIndex plan) pkgid of- Just (Configured pkg) -> pkg- _ -> internalError $ "not configured or no such pkg " ++ display pkgid+ Just (Processing pkg) -> pkg+ _ -> internalError $ "not in processing state or no such pkg " ++ display pkgid --- | check 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. -- checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage checkConfiguredPackage (Configured pkg) = Just pkg@@ -334,6 +354,7 @@ where showPlanState (PreExisting _) = "pre-existing" showPlanState (Configured _) = "configured"+ showPlanState (Processing _) = "processing" showPlanState (Installed _ _) = "installed" showPlanState (Failed _ _) = "failed" @@ -409,8 +430,12 @@ stateDependencyRelation (Configured _) (PreExisting _) = True stateDependencyRelation (Configured _) (Configured _) = True+stateDependencyRelation (Configured _) (Processing _) = True stateDependencyRelation (Configured _) (Installed _ _) = True +stateDependencyRelation (Processing _) (PreExisting _) = True+stateDependencyRelation (Processing _) (Installed _ _) = True+ stateDependencyRelation (Installed _ _) (PreExisting _) = True stateDependencyRelation (Installed _ _) (Installed _ _) = True @@ -419,6 +444,7 @@ -- several other packages and if one of the deps fail then we fail -- but we still depend on the other ones that did not fail: stateDependencyRelation (Failed _ _) (Configured _) = True+stateDependencyRelation (Failed _ _) (Processing _) = True stateDependencyRelation (Failed _ _) (Installed _ _) = True stateDependencyRelation (Failed _ _) (Failed _ _) = True
+ Distribution/Client/JobControl.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Client.JobControl+-- Copyright : (c) Duncan Coutts 2012+-- License : BSD-like+--+-- Maintainer : cabal-devel@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- A job control concurrency abstraction+-----------------------------------------------------------------------------+module Distribution.Client.JobControl (+ JobControl,+ newSerialJobControl,+ newParallelJobControl,+ spawnJob,+ collectJob,++ JobLimit,+ newJobLimit,+ withJobLimit,+ ) where++import Control.Monad+import Control.Concurrent+import Control.Exception+import Prelude hiding (catch)+++data JobControl m a = JobControl {+ spawnJob :: m a -> m (),+ collectJob :: m a+ }+++newSerialJobControl :: IO (JobControl IO a)+newSerialJobControl = do+ queue <- newChan+ return JobControl {+ spawnJob = spawn queue,+ collectJob = collect queue+ }+ where+ spawn :: Chan (IO a) -> IO a -> IO ()+ spawn = writeChan++ collect :: Chan (IO a) -> IO a+ collect = join . readChan++newParallelJobControl :: IO (JobControl IO a)+newParallelJobControl = do+ resultVar <- newEmptyMVar+ return JobControl {+ spawnJob = spawn resultVar,+ collectJob = collect resultVar+ }+ where+ spawn :: MVar (Either SomeException a) -> IO a -> IO ()+ spawn resultVar job =+ mask $ \restore ->+ forkIO (do res <- try (restore job)+ putMVar resultVar res)+ >> return ()++ collect :: MVar (Either SomeException a) -> IO a+ collect resultVar =+ takeMVar resultVar >>= either throw return+++data JobLimit = JobLimit QSem++newJobLimit :: Int -> IO JobLimit+newJobLimit n =+ fmap JobLimit (newQSem n)++withJobLimit :: JobLimit -> IO a -> IO a+withJobLimit (JobLimit sem) =+ bracket_ (waitQSem sem) (signalQSem sem)
Distribution/Client/Setup.hs view
@@ -62,7 +62,7 @@ import Distribution.Package ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import Distribution.Text- ( Text(parse), display )+ ( Text(..), display ) import Distribution.ReadE ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse@@ -615,7 +615,8 @@ installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel, installSymlinkBinDir :: Flag FilePath,- installOneShot :: Flag Bool+ installOneShot :: Flag Bool,+ installNumJobs :: Flag Int } defaultInstallFlags :: InstallFlags@@ -638,7 +639,8 @@ installLogFile = mempty, installBuildReports = Flag NoReports, installSymlinkBinDir = mempty,- installOneShot = Flag False+ installOneShot = Flag False,+ installNumJobs = Flag 1 } where docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")@@ -786,6 +788,13 @@ "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v }) (yesNoOpt showOrParseArgs)++ , option "j" ["jobs"]+ "Run NUM jobs simultaneously."+ installNumJobs (\v flags -> flags { installNumJobs = v })+ (reqArg "NUM" (readP_to_E (\_ -> "jobs should be a number")+ (fmap toFlag (Parse.readS_to_P reads)))+ (map show . flagToList)) ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids ParseArgs -> option [] ["only"]@@ -815,7 +824,8 @@ installLogFile = mempty, installBuildReports = mempty, installSymlinkBinDir = mempty,- installOneShot = mempty+ installOneShot = mempty,+ installNumJobs = mempty } mappend a b = InstallFlags { installDocumentation = combine installDocumentation,@@ -836,7 +846,8 @@ installLogFile = combine installLogFile, installBuildReports = combine installBuildReports, installSymlinkBinDir = combine installSymlinkBinDir,- installOneShot = combine installOneShot+ installOneShot = combine installOneShot,+ installNumJobs = combine installNumJobs } where combine field = field a `mappend` field b
Distribution/Client/SetupWrapper.hs view
@@ -76,26 +76,28 @@ import Data.Char ( isSpace ) data SetupScriptOptions = SetupScriptOptions {- useCabalVersion :: VersionRange,- useCompiler :: Maybe Compiler,- usePackageDB :: PackageDBStack,- usePackageIndex :: Maybe PackageIndex,- useProgramConfig :: ProgramConfiguration,- useDistPref :: FilePath,- useLoggingHandle :: Maybe Handle,- useWorkingDir :: Maybe FilePath+ useCabalVersion :: VersionRange,+ useCompiler :: Maybe Compiler,+ usePackageDB :: PackageDBStack,+ usePackageIndex :: Maybe PackageIndex,+ useProgramConfig :: ProgramConfiguration,+ useDistPref :: FilePath,+ useLoggingHandle :: Maybe Handle,+ useWorkingDir :: Maybe FilePath,+ forceExternalSetupMethod :: Bool } defaultSetupScriptOptions :: SetupScriptOptions defaultSetupScriptOptions = SetupScriptOptions {- useCabalVersion = anyVersion,- useCompiler = Nothing,- usePackageDB = [GlobalPackageDB, UserPackageDB],- usePackageIndex = Nothing,- useProgramConfig = emptyProgramConfiguration,- useDistPref = defaultDistPref,- useLoggingHandle = Nothing,- useWorkingDir = Nothing+ useCabalVersion = anyVersion,+ useCompiler = Nothing,+ usePackageDB = [GlobalPackageDB, UserPackageDB],+ usePackageIndex = Nothing,+ useProgramConfig = emptyProgramConfiguration,+ useDistPref = defaultDistPref,+ useLoggingHandle = Nothing,+ useWorkingDir = Nothing,+ forceExternalSetupMethod = False } setupWrapper :: Verbosity@@ -135,11 +137,12 @@ -- determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod determineSetupMethod options buildType'+ | forceExternalSetupMethod options = externalSetupMethod | isJust (useLoggingHandle options)- || buildType' == Custom = externalSetupMethod+ || buildType' == Custom = externalSetupMethod | cabalVersion `withinRange`- useCabalVersion options = internalSetupMethod- | otherwise = externalSetupMethod+ useCabalVersion options = internalSetupMethod+ | otherwise = externalSetupMethod type SetupMethod = Verbosity -> SetupScriptOptions
Distribution/Client/Tar.hs view
@@ -264,12 +264,12 @@ -- * Tar paths -- --- | The classic tar format allowed just 100 charcters for the file name. The+-- | The classic tar format allowed just 100 characters for the file name. The -- USTAR format extended this with an extra 155 characters, however it uses a -- complex method of splitting the name between the two sections. -- -- Instead of just putting any overflow into the extended area, it uses the--- extended area as a prefix. The agrevating insane bit however is that the+-- extended area as a prefix. The aggravating insane bit however is that the -- prefix (if any) must only contain a directory prefix. That is the split -- between the two areas must be on a directory separator boundary. So there is -- no simple calculation to work out if a file name is too long. Instead we
Distribution/Client/Upload.hs view
@@ -15,12 +15,10 @@ import qualified Distribution.Client.BuildReports.Upload as BuildReport import Network.Browser- ( BrowserAction, request- , Authority(..), addAuthority )+ ( request ) import Network.HTTP ( Header(..), HeaderName(..), findHeader , Request(..), RequestMethod(..), Response(..) )-import Network.TCP (HandleStream) import Network.URI (URI(uriPath), parseURI) import Data.Char (intToDigit)@@ -51,12 +49,7 @@ else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword- let auth = addAuthority AuthBasic {- auRealm = "Hackage",- auUsername = username,- auPassword = password,- auSite = uploadURI- }+ let auth = Just (username, password) flip mapM_ paths $ \path -> do notice verbosity $ "Uploading " ++ path ++ "... " handlePackage verbosity uploadURI auth path@@ -82,17 +75,9 @@ report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO () report verbosity repos mUsername mPassword = do- let uploadURI = if isOldHackageURI targetRepoURI- then legacyUploadURI- else targetRepoURI{uriPath = ""} Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword- let auth = addAuthority AuthBasic {- auRealm = "Hackage",- auUsername = username,- auPassword = password,- auSite = uploadURI- }+ let auth = Just (username, password) forM_ repos $ \repo -> case repoKind repo of Left remoteRepo -> do dotCabal <- defaultCabalDir@@ -111,16 +96,14 @@ cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] return () Right{} -> return ()- where- targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given check :: Verbosity -> [FilePath] -> IO () check verbosity paths = do flip mapM_ paths $ \path -> do notice verbosity $ "Checking " ++ path ++ "... "- handlePackage verbosity checkURI (return ()) path+ handlePackage verbosity checkURI Nothing path -handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()+handlePackage :: Verbosity -> URI -> Maybe (String, String) -> FilePath -> IO () handlePackage verbosity uri auth path = do req <- mkRequest uri path
cabal-install.cabal view
@@ -1,5 +1,5 @@ Name: cabal-install-Version: 0.14.0+Version: 0.14.1 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing@@ -26,8 +26,8 @@ Cabal-Version: >= 1.6 source-repository head- type: darcs- location: http://darcs.haskell.org/cabal/+ type: git+ location: https://github.com/haskell/cabal/ subdir: cabal-install flag old-base@@ -38,7 +38,7 @@ Executable cabal Main-Is: Main.hs- ghc-options: -Wall+ ghc-options: -Wall -threaded if impl(ghc >= 6.8) ghc-options: -fwarn-tabs Other-Modules:@@ -86,6 +86,7 @@ Distribution.Client.Install Distribution.Client.InstallPlan Distribution.Client.InstallSymlink+ Distribution.Client.JobControl Distribution.Client.List Distribution.Client.PackageIndex Distribution.Client.PackageUtils@@ -108,7 +109,7 @@ build-depends: base >= 2 && < 5, Cabal >= 1.14.0 && < 1.15, filepath >= 1.0 && < 1.4,- network >= 1 && < 3,+ network >= 1 && < 2.4, HTTP >= 4000.0.2 && < 4001, zlib >= 0.4 && < 0.6, time >= 1.1 && < 1.5,