diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Assignment.hs b/Distribution/Client/Dependency/Modular/Assignment.hs --- a/Distribution/Client/Dependency/Modular/Assignment.hs +++ b/Distribution/Client/Dependency/Modular/Assignment.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs --- a/Distribution/Client/Dependency/Modular/Builder.hs +++ b/Distribution/Client/Dependency/Modular/Builder.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs --- a/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/Distribution/Client/Dependency/Modular/Dependency.hs @@ -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) diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs --- a/Distribution/Client/Dependency/Modular/Explore.hs +++ b/Distribution/Client/Dependency/Modular/Explore.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs --- a/Distribution/Client/Dependency/Modular/Flag.hs +++ b/Distribution/Client/Dependency/Modular/Flag.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Index.hs b/Distribution/Client/Dependency/Modular/Index.hs --- a/Distribution/Client/Dependency/Modular/Index.hs +++ b/Distribution/Client/Dependency/Modular/Index.hs @@ -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. diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs --- a/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ b/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -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, diff --git a/Distribution/Client/Dependency/Modular/Log.hs b/Distribution/Client/Dependency/Modular/Log.hs --- a/Distribution/Client/Dependency/Modular/Log.hs +++ b/Distribution/Client/Dependency/Modular/Log.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs --- a/Distribution/Client/Dependency/Modular/Message.hs +++ b/Distribution/Client/Dependency/Modular/Message.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs --- a/Distribution/Client/Dependency/Modular/Preference.hs +++ b/Distribution/Client/Dependency/Modular/Preference.hs @@ -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'. -- diff --git a/Distribution/Client/Dependency/Modular/Solver.hs b/Distribution/Client/Dependency/Modular/Solver.hs --- a/Distribution/Client/Dependency/Modular/Solver.hs +++ b/Distribution/Client/Dependency/Modular/Solver.hs @@ -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": diff --git a/Distribution/Client/Dependency/Modular/Tree.hs b/Distribution/Client/Dependency/Modular/Tree.hs --- a/Distribution/Client/Dependency/Modular/Tree.hs +++ b/Distribution/Client/Dependency/Modular/Tree.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Validate.hs b/Distribution/Client/Dependency/Modular/Validate.hs --- a/Distribution/Client/Dependency/Modular/Validate.hs +++ b/Distribution/Client/Dependency/Modular/Validate.hs @@ -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 diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -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 diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -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 diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -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 diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -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 diff --git a/Distribution/Client/JobControl.hs b/Distribution/Client/JobControl.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/JobControl.hs @@ -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) diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -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 diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -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 diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -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 diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -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 diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,5 +1,5 @@ Name: cabal-install -Version: 0.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,