commercialhaskell · qrilka · Feb 5, 2019 · Jan 28, 2019 · Jan 28, 2019 · Jan 28, 2019
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -37,6 +37,10 @@ Major changes:
       their exact versions.
     * The `ignore-revision-mismatch` setting is no longer needed, and
       has been removed.
+    * Overriding GHC boot packages results in any other GHC boot
+      packages depending on it being no longer available as a dependency,
+      such packages need to be added explicitly when needed. See
+      [#4510] (https://github.com/commercialhaskell/stack/issues/4510).
 * Upgrade to Cabal 2.4
     * Note that, in this process, the behavior of file globbing has
       been modified to match that of Cabal. In particular, this means

diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
@@ -219,7 +219,8 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
             planDebug $ show errs
             stackYaml <- view stackYamlL
             stackRoot <- view stackRootL
-            prettyErrorNoIndent $ pprintExceptions errs stackYaml stackRoot parents (wanted ctx)
+            prettyErrorNoIndent $
+                pprintExceptions errs stackYaml stackRoot parents (wanted ctx) prunedGlobalDeps
             throwM $ ConstructPlanFailed "Plan construction failed."
   where
     hasBaseInDeps = Map.member (mkPackageName "base") (smDeps sourceMap)
@@ -234,28 +235,21 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
         , localNames = Map.keysSet (smProject sourceMap)
         }
 
+    prunedGlobalDeps = flip Map.mapMaybe (smGlobal sourceMap) $ \gp ->
+      case gp of
+         ReplacedGlobalPackage deps ->
+           let pruned = filter (not . inSourceMap) deps
+           in if null pruned then Nothing else Just pruned
+         GlobalPackage _ -> Nothing
+
+    inSourceMap pname = pname `Map.member` smDeps sourceMap ||
+                        pname `Map.member` smProject sourceMap
+
     getSources = do
       pPackages <- for (smProject sourceMap) $ \pp -> do
         lp <- loadLocalPackage sourceMap pp
         return $ PSFilePath lp
       bopts <- view $ configL.to configBuild
-      env <- ask
-      let buildHaddocks = shouldHaddockDeps bopts
-          globalToSource name gp | name `Set.member` wiredInPackages = pure Nothing
-                                 | otherwise = do
-            let version = gpVersion gp
-            mrev <- getLatestHackageRevision name version
-            forM mrev $ \(_rev, cfKey, treeKey) ->
-                let loc = PLIHackage (PackageIdentifier name version) cfKey treeKey
-                    common = CommonPackage
-                      { cpGPD = runRIO env $ loadCabalFile (PLImmutable loc)
-                      , cpName = name
-                      , cpFlags = mempty
-                      , cpGhcOptions = mempty
-                      , cpHaddocks = buildHaddocks
-                      }
-                in pure $ PSRemote loc version NotFromSnapshot common
-      globalDeps <- Map.traverseMaybeWithKey globalToSource $ smGlobal sourceMap
       deps <- for (smDeps sourceMap) $ \dp ->
         case dpLocation dp of
           PLImmutable loc ->
@@ -264,7 +258,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
             pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)
             lp <- loadLocalPackage sourceMap pp
             return $ PSFilePath lp
-      return $ pPackages <> deps <> globalDeps
+      return $ pPackages <> deps
 
 -- | State to be maintained during the calculation of local packages
 -- to unregister.
@@ -972,8 +966,9 @@ pprintExceptions
     -> Path Abs Dir
     -> ParentMap
     -> Set PackageName
+    -> Map PackageName [PackageName]
     -> StyleDoc
-pprintExceptions exceptions stackYaml stackRoot parentMap wanted' =
+pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps =
     mconcat $
       [ flow "While constructing the build plan, the following exceptions were encountered:"
       , line <> line
@@ -1070,6 +1065,13 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' =
         | name `Set.member` allNotInBuildPlan = Nothing
         | name `Set.member` wiredInPackages =
             Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (style Current . fromString . packageNameString $ name)
+        | Just pruned <- Map.lookup name prunedGlobalDeps =
+            let prunedDeps = map (style Current . fromString . packageNameString) pruned
+            in Just $ flow "Can't use GHC boot package" <+>
+                      (style Current . fromString . packageNameString $ name) <+>
+                      flow "when it has an overriden dependency, " <+>
+                      flow "you need to add the following as explicit dependencies to the project:" <+>
+                      line <+> encloseSep "" "" ", " prunedDeps
         | otherwise = Just $ flow "Unknown package:" <+> (style Current . fromString . packageNameString $ name)
 
     pprintFlags flags

diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs
@@ -100,12 +100,21 @@ loadSourceMap smt boptsCli sma = do
                          then boptsHaddock bopts
                          else shouldHaddockDeps bopts
                }
-        globals = smaGlobal sma `M.difference` smtDeps smt
         packageCliFlags = Map.fromList $
           mapMaybe maybeProjectFlags $
           Map.toList (boptsCLIFlags boptsCli)
         maybeProjectFlags (ACFByName name, fs) = Just (name, fs)
         maybeProjectFlags _ = Nothing
+        actualGlobals = flip Map.mapMaybe (smaGlobal sma) $ \gp ->
+            case gp of
+                ReplacedGlobalPackage _ -> Nothing
+                GlobalPackage v -> Just v
+    check <- globalCondCheck
+    (prunedGlobals, keptGlobals) <-
+        partitionReplacedDependencies actualGlobals (Map.keysSet deps) check
+    let globals = Map.map GlobalPackage keptGlobals <>
+                  Map.map ReplacedGlobalPackage prunedGlobals <>
+                  Map.filter isReplacedGlobal (smaGlobal sma)
     checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps
     smh <- hashSourceMapData (whichCompiler compiler) deps
     return

diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs
@@ -304,26 +304,13 @@ resolveRawTarget sma allLocs (ri, rt) =
           , rrAddedDep = Nothing
           , rrPackageType = PTProject
           }
-      | Map.member name deps ||
-        Map.member name globals = return $ Right ResolveResult
-          { rrName = name
-          , rrRaw = ri
-          , rrComponent = Nothing
-          , rrAddedDep = Nothing
-          , rrPackageType = PTDependency
-          }
-      | otherwise = do
-          mloc <- getLatestHackageLocation name UsePreferredVersions
-          pure $ case mloc of
-            Nothing -> deferToConstructPlan name
-            Just loc -> do
-              Right ResolveResult
-                    { rrName = name
-                    , rrRaw = ri
-                    , rrComponent = Nothing
-                    , rrAddedDep = Just loc
-                    , rrPackageType = PTDependency
-                    }
+      | Map.member name deps =
+          pure $ deferToConstructPlan name
+      | Just gp <- Map.lookup name globals =
+          case gp of
+              GlobalPackage _ -> pure $ deferToConstructPlan name
+              ReplacedGlobalPackage _ -> hackageLatest name
+      | otherwise = hackageLatest name
 
     -- Note that we use CFILatest below, even though it's
     -- non-reproducible, to avoid user confusion. In any event,
@@ -341,20 +328,10 @@ resolveRawTarget sma allLocs (ri, rt) =
           case Map.lookup name allLocs of
             -- Installing it from the package index, so we're cool
             -- with overriding it if necessary
-            Just (PLImmutable (PLIHackage (PackageIdentifier _name versionLoc) cfKey treeKey)) ->
-              pure $ Right ResolveResult
-                  { rrName = name
-                  , rrRaw = ri
-                  , rrComponent = Nothing
-                  , rrAddedDep =
-                      if version == versionLoc
-                        -- But no need to override anyway, this is already the
-                        -- version we have
-                        then Nothing
-                        -- OK, we'll override it
-                        else Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey
-                  , rrPackageType = PTDependency
-                  }
+            Just (PLImmutable (PLIHackage (PackageIdentifier _name versionLoc) _cfKey _treeKey)) ->
+              if version == versionLoc
+              then pure $ deferToConstructPlan name
+              else hackageLatestRevision name version
             -- The package was coming from something besides the
             -- index, so refuse to do the override
             Just loc' -> pure $ Left $ T.concat
@@ -377,6 +354,31 @@ resolveRawTarget sma allLocs (ri, rt) =
                   , rrPackageType = PTDependency
                   }
 
+    hackageLatest name = do
+        mloc <- getLatestHackageLocation name UsePreferredVersions
+        pure $ case mloc of
+          Nothing -> deferToConstructPlan name
+          Just loc -> do
+            Right ResolveResult
+                  { rrName = name
+                  , rrRaw = ri
+                  , rrComponent = Nothing
+                  , rrAddedDep = Just loc
+                  , rrPackageType = PTDependency
+                  }
+
+    hackageLatestRevision name version = do
+        mrev <- getLatestHackageRevision name version
+        pure $ case mrev of
+          Nothing -> deferToConstructPlan name
+          Just (_rev, cfKey, treeKey) -> Right ResolveResult
+            { rrName = name
+            , rrRaw = ri
+            , rrComponent = Nothing
+            , rrAddedDep = Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey
+            , rrPackageType = PTDependency
+            }
+
     -- This is actually an error case. We _could_ return a
     -- Left value here, but it turns out to be better to defer
     -- this until the ConstructPlan phase, and let it complain
@@ -446,8 +448,8 @@ parseTargets needTargets haddockDeps boptscli smActual = do
 
   let deps = smaDeps smActual
       globals = smaGlobal smActual
-      latestGlobal name gp = do
-        let version = gpVersion gp
+      latestGlobal _ (ReplacedGlobalPackage _) = pure Nothing
+      latestGlobal name (GlobalPackage version) = do
         mrev <- getLatestHackageRevision name version
         forM mrev $ \(_rev, cfKey, treeKey) -> do
           let ident = PackageIdentifier name version

diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs
@@ -10,10 +10,12 @@ module Stack.SourceMap
     , loadGlobalHints
     , toActual
     , checkFlagsUsedThrowing
+    , globalCondCheck
     ) where
 
 import qualified Data.Conduit.List as CL
 import qualified Distribution.PackageDescription as PD
+import Distribution.System (Platform(..))
 import Pantry
 import qualified RIO
 import qualified RIO.Map as Map
@@ -111,26 +113,26 @@ getPLIVersion (PLIRepo _ pm) = pkgVersion $ pmIdent pm
 globalsFromDump ::
        (HasLogFunc env, HasProcessContext env)
     => ActualCompiler
-    -> RIO env (Map PackageName GlobalPackage)
+    -> RIO env (Map PackageName Version)
 globalsFromDump compiler = do
     let pkgConduit =
             conduitDumpPackage .|
             CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)
         toGlobals ds = Map.fromList $ map toGlobal $ Map.elems ds
         toGlobal d =
             ( pkgName $ dpPackageIdent d
-            , GlobalPackage (pkgVersion $ dpPackageIdent d))
+            , pkgVersion $ dpPackageIdent d)
     toGlobals <$> ghcPkgDump (whichCompiler compiler) [] pkgConduit
 
 globalsFromHints ::
        HasConfig env
     => WantedCompiler
-    -> RIO env (Map PackageName GlobalPackage)
+    -> RIO env (Map PackageName Version)
 globalsFromHints compiler = do
     ghfp <- globalHintsFile
     mglobalHints <- loadGlobalHints ghfp compiler
     case mglobalHints of
-        Just hints -> pure $ Map.map GlobalPackage hints
+        Just hints -> pure hints
         Nothing -> do
             logWarn $ "Unable to load global hints for " <> RIO.display compiler
             pure mempty
@@ -146,8 +148,11 @@ toActual smw downloadCompiler ac = do
         case downloadCompiler of
             WithDownloadCompiler -> globalsFromDump ac
             SkipDownloadCompiler -> globalsFromHints (actualToWanted ac)
-    let globals =
-            allGlobals `Map.difference` smwProject smw `Map.difference` smwDeps smw
+    check <- globalCondCheck
+    (prunedGlobals, keptGlobals) <-
+        partitionReplacedDependencies allGlobals (Map.keysSet $ smwDeps smw) check
+    let globals = Map.map GlobalPackage keptGlobals <>
+                  Map.map ReplacedGlobalPackage prunedGlobals
     return
         SMActual
         { smaCompiler = ac
@@ -156,6 +161,15 @@ toActual smw downloadCompiler ac = do
         , smaGlobal = globals
         }
 
+-- | Simple cond check for boot packages - checks only OS and Arch
+globalCondCheck :: (HasConfig env) => RIO env (PD.ConfVar -> Either PD.ConfVar Bool)
+globalCondCheck = do
+  Platform arch os <- view platformL
+  let condCheck (PD.OS os') = pure $ os' == os
+      condCheck (PD.Arch arch') = pure $ arch' == arch
+      condCheck c = Left c
+  return condCheck
+
 checkFlagsUsedThrowing ::
        (MonadIO m, MonadThrow m)
     => Map PackageName (Map FlagName Bool)

diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs
@@ -17,6 +17,7 @@ module Stack.Types.SourceMap
   , ProjectPackage (..)
   , CommonPackage (..)
   , GlobalPackage (..)
+  , isReplacedGlobal
   , SourceMapHash (..)
   ) where
 
@@ -61,10 +62,17 @@ data ProjectPackage = ProjectPackage
   , ppResolvedDir :: !(ResolvedPath Dir)
   }
 
--- | A view of a package installed in the global package database.
-newtype GlobalPackage = GlobalPackage
-  { gpVersion :: Version
-  }
+-- | A view of a package installed in the global package database also
+-- could include marker for a replaced global package (could be replaced
+-- because of a replaced dependency)
+data GlobalPackage
+  = GlobalPackage !Version
+  | ReplacedGlobalPackage ![PackageName]
+  deriving Eq
+
+isReplacedGlobal :: GlobalPackage -> Bool
+isReplacedGlobal (ReplacedGlobalPackage _) = True
+isReplacedGlobal (GlobalPackage _) = False
 
 -- | A source map with information on the wanted (but not actual)
 -- compiler. This is derived by parsing the @stack.yaml@ file for

diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml
@@ -61,6 +61,7 @@ dependencies:
 - text-metrics
 - resourcet
 - rio-prettyprint
+- mtl
 
 # FIXME remove when we drop store
 - integer-gmp

diff --git a/subs/pantry/pantry.cabal b/subs/pantry/pantry.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 097f1c956c3050b63f58c0a2ce38f9eebb02d7e1bfabc081d945a42936608f8b
+-- hash: e07cbc430962c6f97d47cabc25ad162a437b0286c8c77ff49ce54337ebedac86
 
 name:           pantry
 version:        0.1.0.0
@@ -82,6 +82,7 @@ library
     , integer-gmp
     , memory
     , mono-traversable
+    , mtl
     , network
     , network-uri
     , path
@@ -181,6 +182,7 @@ test-suite spec
     , integer-gmp
     , memory
     , mono-traversable
+    , mtl
     , network
     , network-uri
     , pantry