adding a solver flag for shadowing of installed packages

cabal-install/Distribution/Client/Dependency.hs

@@ -46,6 +46,7 @@ module Distribution.Client.Dependency (
     setReorderGoals,
     setIndependentGoals,
     setAvoidReinstalls,
+    setShadowPkgs,
     setMaxBackjumps,
     addSourcePackages,
     hideInstalledPackagesSpecificByInstalledPackageId,
@@ -111,6 +112,7 @@ data DepResolverParams = DepResolverParams {
        depResolverReorderGoals      :: Bool,
        depResolverIndependentGoals  :: Bool,
        depResolverAvoidReinstalls   :: Bool,
+       depResolverShadowPkgs        :: Bool,
        depResolverMaxBackjumps      :: Maybe Int
      }
 
@@ -143,6 +145,7 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
        depResolverReorderGoals      = False,
        depResolverIndependentGoals  = False,
        depResolverAvoidReinstalls   = False,
+       depResolverShadowPkgs        = False,
        depResolverMaxBackjumps      = Nothing
      }
 
@@ -194,6 +197,12 @@ setAvoidReinstalls b params =
       depResolverAvoidReinstalls = b
     }
 
+setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams
+setShadowPkgs b params =
+    params {
+      depResolverShadowPkgs = b
+    }
+
 setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
 setMaxBackjumps n params =
     params {
@@ -344,7 +353,7 @@ resolveDependencies platform comp _solver params
 resolveDependencies platform comp  solver params =
 
     fmap (mkInstallPlan platform comp)
-  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls maxBkjumps)
+  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps)
                      platform comp installedPkgIndex sourcePkgIndex
                      preferences constraints targets
   where
@@ -356,6 +365,7 @@ resolveDependencies platform comp  solver params =
       reorderGoals
       indGoals
       noReinstalls
+      shadowing
       maxBkjumps      = dontUpgradeBasePackage
                       . hideBrokenInstalledPackages
                       $ params
@@ -432,7 +442,7 @@ resolveWithoutDependencies :: DepResolverParams
                            -> Either [ResolveNoDepsError] [SourcePackage]
 resolveWithoutDependencies (DepResolverParams targets constraints
                               prefs defpref installedPkgIndex sourcePkgIndex
-                              _reorderGoals _indGoals _avoidReinstalls _maxBjumps) =
+                              _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) =
     collectEithers (map selectPackage targets)
   where
     selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage

cabal-install/Distribution/Client/Dependency/Modular.hs

@@ -41,7 +41,7 @@ modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns =
   solve sc idx pprefs gcs pns
     where
       -- Indices have to be converted into solver-specific uniform index.
-      idx    = convPIs os arch cid iidx sidx
+      idx    = convPIs os arch cid (shadowPkgs sc) iidx sidx
       -- Constraints have to be converted into a finite map indexed by PN.
       gcs    = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)
 

cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs

@@ -31,17 +31,17 @@ import Distribution.Client.Dependency.Modular.Version
 -- packages if there are several installed packages of the same version.
 -- There are currently some shortcomings in both GHC and Cabal in
 -- resolving these situations. However, the right thing to do is to
--- fix the problem there, so for now, shadowing is disabled here --
--- although it's easy enough to activate.
-convPIs :: OS -> Arch -> CompilerId ->
+-- fix the problem there, so for now, shadowing is only activated if
+-- explicitly requested.
+convPIs :: OS -> Arch -> CompilerId -> Bool ->
            SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index
-convPIs os arch cid iidx sidx =
-  mkIndex (convIPI' iidx ++ convSPI' os arch cid sidx)
+convPIs os arch cid sip iidx sidx =
+  mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx)
 
 -- | Convert a Cabal installed package index to the simpler,
 -- more uniform index format of the solver.
-convIPI' :: SI.PackageIndex -> [(PN, I, PInfo)]
-convIPI' idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx
+convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)]
+convIPI' sip idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx
   where
     -- group installed packages by version
     versioned = L.map (groupBy (equating packageVersion))
@@ -49,12 +49,12 @@ convIPI' idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx
     -- the same version
     combine f pkgs = [ g (f p) | pbn <- pkgs, pbv <- pbn,
                                  (g, p) <- zip (id : repeat shadow) pbv ]
-    -- shadowing is recorded in the package info -- currently disabled
-    shadow = id
-    -- shadow (pn, i, PInfo fdeps fds encs _) = (pn, i, PInfo fdeps fds encs (Just Shadowed))
+    -- shadowing is recorded in the package info
+    shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))
+    shadow x                                     = x
 
-convIPI :: SI.PackageIndex -> Index
-convIPI = mkIndex . convIPI'
+convIPI :: Bool -> SI.PackageIndex -> Index
+convIPI sip = mkIndex . convIPI' sip
 
 -- | Convert a single installed package into the solver-specific format.
 convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)

cabal-install/Distribution/Client/Dependency/Modular/Solver.hs

@@ -20,6 +20,7 @@ data SolverConfig = SolverConfig {
   preferEasyGoalChoices :: Bool,
   independentGoals      :: Bool,
   avoidReinstalls       :: Bool,
+  shadowPkgs            :: Bool,
   maxBackjumps          :: Maybe Int
 }
 

cabal-install/Distribution/Client/Fetch.hs

@@ -149,6 +149,8 @@ planPackages verbosity comp fetchFlags
 
       . setReorderGoals reorderGoals
 
+      . setShadowPkgs shadowPkgs
+
         -- 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
@@ -162,6 +164,7 @@ planPackages verbosity comp fetchFlags
 
     reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)
     independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
+    shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)
     maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)
 
 

cabal-install/Distribution/Client/Install.hs

@@ -252,6 +252,8 @@ planPackages comp solver configFlags configExFlags installFlags
 
       . setAvoidReinstalls avoidReinstalls
 
+      . setShadowPkgs shadowPkgs
+
       . setPreferenceDefault (if upgradeDeps then PreferAllLatest
                                              else PreferLatestForSelected)
 
@@ -318,6 +320,7 @@ planPackages comp solver configFlags configExFlags installFlags
     reorderGoals     = fromFlag (installReorderGoals     installFlags)
     independentGoals = fromFlag (installIndependentGoals installFlags)
     avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
+    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
     maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
     upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
     onlyDeps         = fromFlag (installOnlyDeps         installFlags)

cabal-install/Distribution/Client/Setup.hs

@@ -310,6 +310,7 @@ data FetchFlags = FetchFlags {
       fetchMaxBackjumps     :: Flag Int,
       fetchReorderGoals     :: Flag Bool,
       fetchIndependentGoals :: Flag Bool,
+      fetchShadowPkgs       :: Flag Bool,
       fetchVerbosity :: Flag Verbosity
     }
 
@@ -322,6 +323,7 @@ defaultFetchFlags = FetchFlags {
     fetchMaxBackjumps     = Flag defaultMaxBackjumps,
     fetchReorderGoals     = Flag False,
     fetchIndependentGoals = Flag False,
+    fetchShadowPkgs       = Flag False,
     fetchVerbosity = toFlag normal
    }
 
@@ -361,6 +363,7 @@ fetchCommand = CommandUI {
        optionSolverFlags fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
                          fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                          fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
+                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
 
   }
 
@@ -599,6 +602,7 @@ data InstallFlags = InstallFlags {
     installMaxBackjumps     :: Flag Int,
     installReorderGoals     :: Flag Bool,
     installIndependentGoals :: Flag Bool,
+    installShadowPkgs       :: Flag Bool,
     installReinstall        :: Flag Bool,
     installAvoidReinstalls  :: Flag Bool,
     installOverrideReinstall :: Flag Bool,
@@ -621,6 +625,7 @@ defaultInstallFlags = InstallFlags {
     installMaxBackjumps    = Flag defaultMaxBackjumps,
     installReorderGoals    = Flag False,
     installIndependentGoals= Flag False,
+    installShadowPkgs      = Flag False,
     installReinstall       = Flag False,
     installAvoidReinstalls = Flag False,
     installOverrideReinstall = Flag False,
@@ -718,7 +723,8 @@ installOptions showOrParseArgs =
 
       optionSolverFlags installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })
                         installReorderGoals     (\v flags -> flags { installReorderGoals     = v })
-                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) ++
+                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
+                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) ++
 
       [ option [] ["reinstall"]
           "Install even if it means installing the same version again."
@@ -800,6 +806,7 @@ instance Monoid InstallFlags where
     installUpgradeDeps     = mempty,
     installReorderGoals    = mempty,
     installIndependentGoals= mempty,
+    installShadowPkgs      = mempty,
     installOnly            = mempty,
     installOnlyDeps        = mempty,
     installRootCmd         = mempty,
@@ -820,6 +827,7 @@ instance Monoid InstallFlags where
     installUpgradeDeps     = combine installUpgradeDeps,
     installReorderGoals    = combine installReorderGoals,
     installIndependentGoals= combine installIndependentGoals,
+    installShadowPkgs      = combine installShadowPkgs,
     installOnly            = combine installOnly,
     installOnlyDeps        = combine installOnlyDeps,
     installRootCmd         = combine installRootCmd,
@@ -1122,10 +1130,11 @@ optionSolver get set =
                      (flagToList . fmap display))
 
 optionSolverFlags :: (flags -> Flag Int   ) -> (Flag Int    -> 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 getmbj setmbj getrg setrg getig setig =
+optionSolverFlags getmbj setmbj getrg setrg getig setig getsip setsip =
   [ 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
@@ -1136,11 +1145,14 @@ optionSolverFlags getmbj setmbj getrg setrg getig setig =
       "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."
       getrg setrg
       trueArg
-
   , option [] ["independent-goals"]
       "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen."
       getig setig
       trueArg
+  , option [] ["shadow-installed-packages"]
+      "If multiple package instances of the same version are installed, treat all but one as shadowed."
+      getsip setsip
+      trueArg
   ]