Merge pull request #4547 from commercialhaskell/globals-pruning

Globals (GHC boot packages) pruning
commercialhaskell · Feb 5, 2019 · 6ec4ac4 · 6ec4ac4
2 parents 59efd85 + 539a647
commit 6ec4ac4
Show file tree

Hide file tree

Showing 13 changed files with 355 additions and 133 deletions.
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
@@ -70,7 +70,7 @@ localDependencies = do
 loadSourceMap :: HasBuildConfig env
               => SMTargets
               -> BuildOptsCLI
-              -> SMActual
+              -> SMActual DumpedGlobalPackage
               -> RIO env SourceMap
 loadSourceMap smt boptsCli sma = do
     bconfig <- view buildConfigL
@@ -100,12 +100,12 @@ 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
+        globals = pruneGlobals (smaGlobal sma) (Map.keysSet deps)
     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
@@ -211,7 +211,7 @@ data ResolveResult = ResolveResult
 -- the module).
 resolveRawTarget ::
        (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
-    => SMActual
+    => SMActual GlobalPackage
     -> Map PackageName PackageLocation
     -> (RawInput, RawTarget)
     -> RIO env (Either Text ResolveResult)
@@ -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
@@ -432,7 +434,7 @@ parseTargets :: HasBuildConfig env
     => NeedTargets
     -> Bool
     -> BuildOptsCLI
-    -> SMActual
+    -> SMActual GlobalPackage
     -> RIO env SMTargets
 parseTargets needTargets haddockDeps boptscli smActual = do
   logDebug "Parsing the targets"
@@ -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/Ghci.hs b/src/Stack/Ghci.hs
@@ -198,7 +198,7 @@ ghci opts@GhciOpts{..} = do
 preprocessTargets
     :: HasEnvConfig env
     => BuildOptsCLI
-    -> SMActual
+    -> SMActual GlobalPackage
     -> [Text]
     -> RIO env (Either [Path Abs File] (Map PackageName Target))
 preprocessTargets buildOptsCLI sma rawTargets = do
@@ -229,7 +229,7 @@ preprocessTargets buildOptsCLI sma rawTargets = do
 parseMainIsTargets
      :: HasEnvConfig env
      => BuildOptsCLI
-     -> SMActual
+     -> SMActual GlobalPackage
      -> Maybe Text
      -> RIO env (Maybe (Map PackageName Target))
 parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do

diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -63,7 +63,7 @@ import qualified    Data.Yaml as Yaml
 import              Distribution.System (OS, Arch (..), Platform (..))
 import qualified    Distribution.System as Cabal
 import              Distribution.Text (simpleParse)
-import              Distribution.Types.PackageName (mkPackageName)
+import              Distribution.Types.PackageName (mkPackageName, unPackageName)
 import              Distribution.Version (mkVersion)
 import              Lens.Micro (set)
 import              Network.HTTP.StackClient (CheckHexDigest (..), DownloadRequest (..), HashCheck (..),
@@ -87,6 +87,7 @@ import              Stack.Config (loadConfig)
 import              Stack.Constants
 import              Stack.Constants.Config (distRelativeDir)
 import              Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar)
+import              Stack.PackageDump (DumpPackage (..))
 import              Stack.Prelude hiding (Display (..))
 import              Stack.SourceMap
 import              Stack.Setup.Installed
@@ -95,6 +96,7 @@ import              Stack.Types.Compiler
 import              Stack.Types.CompilerBuild
 import              Stack.Types.Config
 import              Stack.Types.Docker
+import              Stack.Types.GhcPkgId (parseGhcPkgId)
 import              Stack.Types.Runner
 import              Stack.Types.SourceMap
 import              Stack.Types.Version
@@ -258,6 +260,7 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do
                     (view envVarsL menv0)
     menv <- mkProcessContext env
 
+    -- FIXME currently this fails with SkipDownloadcompiler
     (compilerVer, cabalVer, globaldb) <- withProcessContext menv $ runConcurrently $ (,,)
         <$> Concurrently (getCompilerVersion wc)
         <*> Concurrently (getCabalPkgVer wc)
@@ -272,9 +275,49 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do
         bcPath = set envOverrideSettingsL (\_ -> return menv) $
                  set processContextL menv bc
     sourceMap <- runRIO bcPath $ do
-      smActual <- toActual (bcSMWanted bc) (bcDownloadCompiler bc) compilerVer
+      (smActual, prunedActual) <- case bcDownloadCompiler bc of
+        SkipDownloadCompiler -> do
+          -- FIXME temprorary version, should be resolved the same way as getCompilerVersion above
+          sma <- actualFromHints (bcSMWanted bc) compilerVer
+          let noDepsDump :: PackageName -> a -> DumpedGlobalPackage
+              noDepsDump pname _ = DumpPackage
+                { dpGhcPkgId = fromMaybe (error "bad package name") $
+                               parseGhcPkgId (T.pack $ unPackageName pname)
+                , dpPackageIdent = PackageIdentifier pname (mkVersion [])
+                , dpParentLibIdent = Nothing
+                , dpLicense = Nothing
+                , dpLibDirs = []
+                , dpLibraries = []
+                , dpHasExposedModules = True
+                , dpExposedModules = mempty
+                , dpDepends = []
+                , dpHaddockInterfaces = []
+                , dpHaddockHtml = Nothing
+                , dpProfiling = ()
+                , dpHaddock = ()
+                , dpSymbols = ()
+                , dpIsExposed = True
+                }
+              fakeDump = sma {
+                smaGlobal = Map.mapWithKey noDepsDump (smaGlobal sma)
+                }
+              fakePruned = sma {
+                smaGlobal = Map.map (\(GlobalPackageVersion v) -> GlobalPackage v)
+                  (smaGlobal sma)
+                }
+          return (fakeDump, fakePruned)
+        WithDownloadCompiler -> do
+          sma <- actualFromGhc (bcSMWanted bc) compilerVer
+          let actualPkgs = Map.keysSet (smaDeps sma) <>
+                           Map.keysSet (smaProject sma)
+          return ( sma
+                 , sma {
+                     smaGlobal = pruneGlobals (smaGlobal sma) actualPkgs
+                     }
+                 )
+
       let haddockDeps = shouldHaddockDeps (configBuild config)
-      targets <- parseTargets needTargets haddockDeps boptsCLI smActual
+      targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual
       loadSourceMap targets boptsCLI smActual
 
     let envConfig0 = EnvConfig
@@ -384,8 +427,12 @@ rebuildEnv envConfig needTargets haddockDeps boptsCLI = do
     let bc = envConfigBuildConfig envConfig
         compilerVer = smCompiler $ envConfigSourceMap envConfig
     runRIO bc $ do
-        smActual <- toActual (bcSMWanted bc) (bcDownloadCompiler bc) compilerVer
-        targets <- parseTargets needTargets haddockDeps boptsCLI smActual
+        smActual <- actualFromGhc (bcSMWanted bc) compilerVer
+        let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual)
+            prunedActual = smActual {
+              smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs
+              }
+        targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual
         sourceMap <- loadSourceMap targets boptsCLI smActual
         return $
             envConfig