diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -50,6 +50,7 @@ setIndependentGoals, setAvoidReinstalls, setShadowPkgs, + setStrongFlags, setMaxBackjumps, addSourcePackages, hideInstalledPackagesSpecificByInstalledPackageId, @@ -119,6 +120,7 @@ depResolverIndependentGoals :: Bool, depResolverAvoidReinstalls :: Bool, depResolverShadowPkgs :: Bool, + depResolverStrongFlags :: Bool, depResolverMaxBackjumps :: Maybe Int } @@ -152,6 +154,7 @@ depResolverIndependentGoals = False, depResolverAvoidReinstalls = False, depResolverShadowPkgs = False, + depResolverStrongFlags = False, depResolverMaxBackjumps = Nothing } @@ -209,6 +212,12 @@ depResolverShadowPkgs = b } +setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams +setStrongFlags b params = + params { + depResolverStrongFlags = b + } + setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params = params { @@ -399,7 +408,7 @@ fmap (mkInstallPlan platform comp) $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls - shadowing maxBkjumps) + shadowing strFlags maxBkjumps) platform comp installedPkgIndex sourcePkgIndex preferences constraints targets where @@ -412,6 +421,7 @@ indGoals noReinstalls shadowing + strFlags maxBkjumps = dontUpgradeBasePackage -- TODO: -- The modular solver can properly deal with broken @@ -495,7 +505,7 @@ resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex _reorderGoals _indGoals _avoidReinstalls - _shadowing _maxBjumps) = + _shadowing _strFlags _maxBjumps) = collectEithers (map selectPackage targets) where selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage diff --git a/Distribution/Client/Dependency/Modular.hs b/Distribution/Client/Dependency/Modular.hs --- a/Distribution/Client/Dependency/Modular.hs +++ b/Distribution/Client/Dependency/Modular.hs @@ -41,7 +41,7 @@ solve sc idx pprefs gcs pns where -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cid (shadowPkgs sc) iidx sidx + idx = convPIs os arch cid (shadowPkgs sc) (strongFlags sc) iidx sidx -- Constraints have to be converted into a finite map indexed by PN. gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs) 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 @@ -46,6 +46,9 @@ go :: RevDepMap -> PSQ OpenGoal () -> [OpenGoal] -> BuildState go g o [] = s { rdeps = g, open = o } go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons ng () o) ngs + -- Note: for 'Flagged' goals, we always insert, so later additions win. + -- This is important, because in general, if a goal is inserted twice, + -- the later addition will have better dependency information. go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons ng () o) ngs go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs) | qpn == qpn' = go g o ngs @@ -69,11 +72,30 @@ scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s where sc = scope s + -- Qualify all package names qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names + -- Introduce all package flags qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs - gs = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs) + -- Combine new package and flag goals + gs = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps) + -- IMPORTANT AND SUBTLE: The order of the concatenation above is + -- important. Flags occur potentially multiple times: both via the + -- flag declaration ('qfdefs') and via dependencies ('qfdeps'). + -- We want the information from qfdeps if it's present, because that + -- includes dependencies between flags. We use qfdefs mainly so that + -- we are forced to make choices for flags that don't affect + -- dependencies at all. + -- + -- When goals are actually extended in 'extendOpen', later additions + -- override earlier additions, so it's important that the + -- lower-quality templates without dependency information come first. -data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasonChain +-- | Datatype that encodes what to build next +data BuildType = + Goals -- ^ build a goal choice node + | OneGoal OpenGoal -- ^ build a node for this goal + | Instance QPN I PInfo QGoalReasonChain -- ^ build a tree for a concrete instance + deriving Show build :: BuildState -> Tree (QGoalReasonChain, Scope) build = ana go @@ -105,8 +127,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 _) _) (FInfo b m) t f) gr) }) = - FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b + go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) = + FChoiceF qfn (gr, sc) (w || 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/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs --- a/Distribution/Client/Dependency/Modular/Flag.hs +++ b/Distribution/Client/Dependency/Modular/Flag.hs @@ -25,9 +25,10 @@ unFlag :: Flag -> String unFlag (FlagName fn) = fn --- | Flag info. Default value, and whether the flag is manual. --- Manual flags can only be set explicitly. -data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool } +-- | Flag info. Default value, whether the flag is manual, and +-- whether the flag is weak. Manual flags can only be set explicitly. +-- Weak flags are typically deferred by the solver. +data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: Bool } deriving (Eq, Ord, Show) -- | Flag defaults. 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 @@ -32,10 +32,10 @@ -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerId -> Bool -> +convPIs :: OS -> Arch -> CompilerId -> Bool -> Bool -> SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index -convPIs os arch cid sip iidx sidx = - mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx) +convPIs os arch cid sip strfl iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch cid strfl sidx) -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. @@ -82,19 +82,19 @@ -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerId -> +convSPI' :: OS -> Arch -> CompilerId -> Bool -> CI.PackageIndex SourcePackage -> [(PN, I, PInfo)] -convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages +convSPI' os arch cid strfl = L.map (convSP os arch cid strfl) . CI.allPackages -convSPI :: OS -> Arch -> CompilerId -> +convSPI :: OS -> Arch -> CompilerId -> Bool -> CI.PackageIndex SourcePackage -> Index -convSPI os arch cid = mkIndex . convSPI' os arch cid +convSPI os arch cid strfl = mkIndex . convSPI' os arch cid strfl -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo) -convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = +convSP :: OS -> Arch -> CompilerId -> Bool -> SourcePackage -> (PN, I, PInfo) +convSP os arch cid strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo - in (pn, i, convGPD os arch cid (PI pn i) gpd) + in (pn, i, convGPD os arch cid strfl (PI pn i) gpd) -- We do not use 'flattenPackageDescription' or 'finalizePackageDescription' -- from 'Distribution.PackageDescription.Configuration' here, because we @@ -104,12 +104,12 @@ -- -- TODO: We currently just take all dependencies from all specified library, -- executable and test components. This does not quite seem fair. -convGPD :: OS -> Arch -> CompilerId -> +convGPD :: OS -> Arch -> CompilerId -> Bool -> PI PN -> GenericPackageDescription -> PInfo -convGPD os arch cid pi +convGPD os arch cid strfl pi (GenericPackageDescription _ flags libs exes tests benchs) = let - fds = flagInfo flags + fds = flagInfo strfl flags in PInfo (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++ @@ -126,9 +126,10 @@ prefix _ [] = [] prefix f fds = [f (concat fds)] --- | Convert flag information. -flagInfo :: [PD.Flag] -> FlagInfo -flagInfo = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m)) +-- | Convert flag information. Automatic flags are now considered weak +-- unless strong flags have been selected explicitly. +flagInfo :: Bool -> [PD.Flag] -> FlagInfo +flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m)))) -- | Convert condition trees to flagged dependencies. convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo -> @@ -164,7 +165,7 @@ go (CNot c) t f = go c f t go (CAnd c d) t f = go c (go d t f) f go (COr c d) t f = go c t (go d t f) - go (Var (Flag fn)) t f = [Flagged (FN pi fn) (fds ! fn) t f] + go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f] go (Var (OS os')) t f | os == os' = t | otherwise = f @@ -174,6 +175,14 @@ go (Var (Impl cf' cvr')) t f | cf == cf' && checkVR cvr' cv = t | otherwise = f + + -- If both branches contain the same package as a simple dep, we lift it to + -- the next higher-level, but without constraints. This heuristic together + -- with deferring flag choices will then usually first resolve this package, + -- and try an already installed version before imposing a default flag choice + -- that might not be what we want. + extractCommon :: FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN + extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) | D.Simple (Dep pn _) <- ps, D.Simple (Dep pn' _) <- ps', pn == pn' ] -- | Convert a Cabal dependency to a solver-specific dependency. convDep :: PN -> Dependency -> Dep PN 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 @@ -138,7 +138,7 @@ 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, []) -> P.fromList xs -- everything's already disabled, leave everything as is (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys) where isDisabled (_, Fail _ _) = True @@ -241,10 +241,11 @@ go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs) go x = x --- | Transformation that tries to avoid making inconsequential --- flag choices early. -deferDefaultFlagChoices :: Tree a -> Tree a -deferDefaultFlagChoices = trav go +-- | Transformation that tries to avoid making weak flag choices early. +-- Weak flags are trivial flags (not influencing dependencies) or such +-- flags that are explicitly declared to be weak in the index. +deferWeakFlagChoices :: Tree a -> Tree a +deferWeakFlagChoices = trav go where go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs) go x = x 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 @@ -21,6 +21,7 @@ independentGoals :: Bool, avoidReinstalls :: Bool, shadowPkgs :: Bool, + strongFlags :: Bool, maxBackjumps :: Maybe Int } @@ -40,9 +41,11 @@ where explorePhase = exploreTreeLog . backjump heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space) + P.deferWeakFlagChoices . + P.preferBaseGoalChoice . if preferEasyGoalChoices sc - then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices - else P.preferBaseGoalChoice + then P.lpreferEasyGoalChoices + else id preferencesPhase = P.preferPackagePreferences userPrefs validationPhase = P.enforceManualFlags . -- can only be done after user constraints P.enforcePackageConstraints userConstraints . 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 @@ -15,7 +15,7 @@ -- | 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 Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial, second Bool whether it's manual + | FChoice QFN a Bool Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's weak/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 @@ -24,6 +24,11 @@ -- Above, a choice is called trivial if it clearly does not matter. The -- special case of triviality we actually consider is if there are no new -- dependencies introduced by this node. + -- + -- A (flag) choice is called weak if we do want to defer it. This is the + -- case for flags that should be implied by what's currently installed on + -- the system, as opposed to flags that are used to explicitly enable or + -- disable some functionality. instance Functor Tree where fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs) diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -154,6 +154,8 @@ . setShadowPkgs shadowPkgs + . setStrongFlags strongFlags + -- Reinstall the targets given on the command line so that the dep -- resolver will decide that they need fetching, even if they're -- already installed. Since we want to get the source packages of @@ -168,6 +170,7 @@ reorderGoals = fromFlag (fetchReorderGoals fetchFlags) independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) + strongFlags = fromFlag (fetchStrongFlags fetchFlags) maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -319,6 +319,8 @@ . setShadowPkgs shadowPkgs + . setStrongFlags strongFlags + . setPreferenceDefault (if upgradeDeps then PreferAllLatest else PreferLatestForSelected) @@ -362,6 +364,7 @@ independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) shadowPkgs = fromFlag (installShadowPkgs installFlags) + strongFlags = fromFlag (installStrongFlags installFlags) maxBackjumps = fromFlag (installMaxBackjumps installFlags) upgradeDeps = fromFlag (installUpgradeDeps installFlags) onlyDeps = fromFlag (installOnlyDeps installFlags) diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -437,6 +437,7 @@ fetchReorderGoals :: Flag Bool, fetchIndependentGoals :: Flag Bool, fetchShadowPkgs :: Flag Bool, + fetchStrongFlags :: Flag Bool, fetchVerbosity :: Flag Verbosity } @@ -450,6 +451,7 @@ fetchReorderGoals = Flag False, fetchIndependentGoals = Flag False, fetchShadowPkgs = Flag False, + fetchStrongFlags = Flag False, fetchVerbosity = toFlag normal } @@ -491,6 +493,7 @@ fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) + fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) } @@ -784,6 +787,7 @@ installReorderGoals :: Flag Bool, installIndependentGoals :: Flag Bool, installShadowPkgs :: Flag Bool, + installStrongFlags :: Flag Bool, installReinstall :: Flag Bool, installAvoidReinstalls :: Flag Bool, installOverrideReinstall :: Flag Bool, @@ -808,6 +812,7 @@ installReorderGoals = Flag False, installIndependentGoals= Flag False, installShadowPkgs = Flag False, + installStrongFlags = Flag False, installReinstall = Flag False, installAvoidReinstalls = Flag False, installOverrideReinstall = Flag False, @@ -826,7 +831,7 @@ docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") defaultMaxBackjumps :: Int -defaultMaxBackjumps = 200 +defaultMaxBackjumps = 2000 defaultSolver :: PreSolver defaultSolver = Choose @@ -909,7 +914,8 @@ installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) installReorderGoals (\v flags -> flags { installReorderGoals = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) - installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) ++ + installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) + installStrongFlags (\v flags -> flags { installStrongFlags = v }) ++ [ option [] ["reinstall"] "Install even if it means installing the same version again." @@ -1004,6 +1010,7 @@ installReorderGoals = mempty, installIndependentGoals= mempty, installShadowPkgs = mempty, + installStrongFlags = mempty, installOnly = mempty, installOnlyDeps = mempty, installRootCmd = mempty, @@ -1026,6 +1033,7 @@ installReorderGoals = combine installReorderGoals, installIndependentGoals= combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, + installStrongFlags = combine installStrongFlags, installOnly = combine installOnly, installOnlyDeps = combine installOnlyDeps, installRootCmd = combine installRootCmd, @@ -1479,8 +1487,9 @@ -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) + -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip = +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip getstrfl setstrfl = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj @@ -1501,7 +1510,11 @@ , option [] ["shadow-installed-packages"] "If multiple package instances of the same version are installed, treat all but one as shadowed." getsip setsip - trueArg + (yesNoOpt showOrParseArgs) + , option [] ["strong-flags"] + "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." + getstrfl setstrfl + (yesNoOpt showOrParseArgs) ] 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: 1.18.0.3 +Version: 1.18.0.4 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing