Make "stack ghci" skip build for local targets if in DB

Author: mgsloan

ChangeLog.md

@@ -37,6 +37,8 @@ Other enhancements:
 * `--[no-]haddock-hyperlink-source` flag added which allows toggling
   of sources being included in Haddock output.
   See [#3099](https://github.com/commercialhaskell/stack/issues/3099)
+* `stack ghci` will now skip building all local targets, even if they have
+  downstream deps, as long as it's registered in the DB.
 
 Bug fixes:
 

src/Stack/Build.hs

@@ -118,7 +118,7 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do
 
     baseConfigOpts <- mkBaseConfigOpts boptsCli
     plan <- withLoadPackage $ \loadPackage ->
-        constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap
+        constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli)
 
     allowLocals <- view $ configL.to configAllowLocals
     unless allowLocals $ case justLocals plan of

src/Stack/Build/ConstructPlan.hs

@@ -178,8 +178,9 @@ constructPlan :: forall env m. (StackM env m, HasEnvConfig env)
               -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package
               -> SourceMap
               -> InstalledMap
+              -> Bool
               -> m Plan
-constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do
+constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do
     $logDebug "Constructing the build plan"
     getVersions0 <- getPackageVersionsIO
 
@@ -210,7 +211,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag
             return $ takeSubset Plan
                 { planTasks = tasks
                 , planFinals = M.fromList finals
-                , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap
+                , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps
                 , planInstallExes =
                     if boptsInstallExes $ bcoBuildOpts baseConfigOpts0
                         then installExes
@@ -260,8 +261,11 @@ mkUnregisterLocal :: Map PackageName Task
                   -> [DumpPackage () () ()]
                   -- ^ Local package database dump
                   -> SourceMap
+                  -> Bool
+                  -- ^ If true, we're doing a special initialBuildSteps
+                  -- build - don't unregister target packages.
                   -> Map GhcPkgId (PackageIdentifier, Text)
-mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap =
+mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps =
     -- We'll take multiple passes through the local packages. This
     -- will allow us to detect that a package should be unregistered,
     -- as well as all packages directly or transitively depending on
@@ -304,9 +308,12 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap =
 
     go' toUnregister ident deps
       -- If we're planning on running a task on it, then it must be
-      -- unregistered
-      | Just _ <- Map.lookup name tasks
-          = Just $ fromMaybe "" $ Map.lookup name dirtyReason
+      -- unregistered, unless it's a target and an initial-build-steps
+      -- build is being done.
+      | Just task <- Map.lookup name tasks
+          = if initialBuildSteps && taskIsTarget task && taskProvides task == ident
+              then Nothing
+              else Just $ fromMaybe "" $ Map.lookup name dirtyReason
       -- Check if we're no longer using the local version
       | Just (PSUpstream _ Snap _ _ _) <- Map.lookup name sourceMap
           = Just "Switching to snapshot installed package"

src/Stack/Build/Execute.hs

@@ -753,7 +753,7 @@ toActions installedMap runInBase ee (mbuild, mfinal) =
 getConfigCache :: (StackM env m, HasEnvConfig env)
                => ExecuteEnv m -> Task -> InstalledMap -> Bool -> Bool
                -> m (Map PackageIdentifier GhcPkgId, ConfigCache)
-getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do
+getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBench = do
     useExactConf <- view $ configL.to configAllowNewer
     let extra =
             -- We enable tests if the test suite dependencies are already
@@ -772,9 +772,16 @@ getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = d
     idMap <- liftIO $ readTVarIO eeGhcPkgIds
     let getMissing ident =
             case Map.lookup ident idMap of
-                Nothing -> error "singleBuild: invariant violated, missing package ID missing"
-                Just (Library ident' x) -> assert (ident == ident') $ Just (ident, x)
-                Just (Executable _) -> Nothing
+                Nothing
+                    -- Expect to instead find it in installedMap if it's
+                    -- an initialBuildSteps target.
+                    | boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task,
+                      Just (_, installed) <- Map.lookup (packageIdentifierName ident) installedMap
+                        -> installedToGhcPkgId ident installed
+                Just installed -> installedToGhcPkgId ident installed
+                _ -> error "singleBuild: invariant violated, missing package ID missing"
+        installedToGhcPkgId ident (Library ident' x) = assert (ident == ident') $ Just (ident, x)
+        installedToGhcPkgId _ (Executable _) = Nothing
         missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing
         TaskConfigOpts missing mkOpts = taskConfigOpts
         opts = mkOpts missing'
@@ -1294,23 +1301,25 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
         $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do
             _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp
 
+            let installedMapHasThisPkg :: Bool
+                installedMapHasThisPkg =
+                    case Map.lookup (packageName package) installedMap of
+                        Just (_, Library ident _) -> ident == taskProvides
+                        Just (_, Executable _) -> True
+                        _ -> False
+
             case ( boptsCLIOnlyConfigure eeBuildOptsCLI
-                 , boptsCLIInitialBuildSteps eeBuildOptsCLI && isTarget
-                 , acDownstream) of
+                 , boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task) of
                 -- A full build is done if there are downstream actions,
                 -- because their configure step will require that this
                 -- package is built. See
                 -- https://github.com/commercialhaskell/stack/issues/2787
-                (True, _, []) -> return Nothing
-                (_, True, []) -> do
+                (True, _) | null acDownstream -> return Nothing
+                (_, True) | null acDownstream || installedMapHasThisPkg -> do
                     initialBuildSteps cabal announce
                     return Nothing
                 _ -> liftM Just $ realBuild cache package pkgDir cabal announce
 
-    isTarget = case taskType of
-        TTLocal lp -> lpWanted lp
-        _ -> False
-
     initialBuildSteps cabal announce = do
         () <- announce ("initial-build-steps" <> annSuffix)
         cabal False ["repl", "stack-initial-build-steps"]

src/Stack/Types/Build.hs

@@ -18,6 +18,7 @@ module Stack.Types.Build
     ,Installed(..)
     ,PackageInstallInfo(..)
     ,Task(..)
+    ,taskIsTarget
     ,taskLocation
     ,LocalPackage(..)
     ,BaseConfigOpts(..)
@@ -449,6 +450,12 @@ data TaskType = TTLocal LocalPackage
               | TTUpstream Package InstallLocation (Maybe GitSHA1)
     deriving Show
 
+taskIsTarget :: Task -> Bool
+taskIsTarget t =
+    case taskType t of
+        TTLocal lp -> lpWanted lp
+        _ -> False
+
 taskLocation :: Task -> InstallLocation
 taskLocation task =
     case taskType task of