Merge pull request #3047 from commercialhaskell/2904-aggressive-unreg…

…ister

Aggressive unregister for #2904

ChangeLog.md

@@ -109,6 +109,10 @@ Bug fixes:
   ([#2977](https://github.com/commercialhaskell/stack/issues/2977))
 * Added support for GHC 8's slightly different warning format for
   dumping warnings from logs.
+* Work around a bug in Cabal/GHC in which package IDs are not unique
+  for different source code, leading to Stack not always rebuilding
+  packages depending on local packages which have
+  changed. ([#2904](https://github.com/commercialhaskell/stack/issues/2904))
 
 ## 1.3.2
 

src/Stack/Build/ConstructPlan.hs

@@ -15,12 +15,12 @@ module Stack.Build.ConstructPlan
     ( constructPlan
     ) where
 
-import           Control.Arrow ((&&&))
 import           Control.Exception.Lifted
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.RWS.Strict
+import           Control.Monad.State.Strict (execState)
 import           Control.Monad.Trans.Resource
 import           Data.Either
 import           Data.Function
@@ -156,7 +156,6 @@ constructPlan :: forall env m. (StackM env m, HasEnvConfig env)
               -> m Plan
 constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do
     $logDebug "Constructing the build plan"
-    let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs
     getVersions0 <- getPackageVersionsIO
 
     econfig <- view envConfigL
@@ -186,7 +185,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag
             return $ takeSubset Plan
                 { planTasks = tasks
                 , planFinals = M.fromList finals
-                , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap
+                , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap
                 , planInstallExes =
                     if boptsInstallExes $ bcoBuildOpts baseConfigOpts0
                         then installExes
@@ -219,29 +218,78 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag
     -- or local packages.
     toolMap = getToolMap mbp0
 
+-- | State to be maintained during the calculation of local packages
+-- to unregister.
+data UnregisterState = UnregisterState
+    { usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text))
+    , usKeep :: ![DumpPackage () () ()]
+    , usAnyAdded :: !Bool
+    }
+
 -- | Determine which packages to unregister based on the given tasks and
 -- already registered local packages
 mkUnregisterLocal :: Map PackageName Task
+                  -- ^ Tasks
                   -> Map PackageName Text
-                  -> Map GhcPkgId PackageIdentifier
+                  -- ^ Reasons why packages are dirty and must be rebuilt
+                  -> [DumpPackage () () ()]
+                  -- ^ Local package database dump
                   -> SourceMap
-                  -> Map GhcPkgId (PackageIdentifier, Maybe Text)
-mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap =
-    Map.unions $ map toUnregisterMap $ Map.toList locallyRegistered
+                  -> Map GhcPkgId (PackageIdentifier, Text)
+mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap =
+    -- 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
+    -- it.
+    loop Map.empty localDumpPkgs
   where
-    toUnregisterMap (gid, ident) =
-        case M.lookup name tasks of
-            Nothing ->
-                case M.lookup name sourceMap of
-                    Just (PSUpstream _ Snap _ _ _) -> Map.singleton gid
-                        ( ident
-                        , Just "Switching to snapshot installed package"
-                        )
-                    _ -> Map.empty
-            Just _ -> Map.singleton gid
-                ( ident
-                , Map.lookup name dirtyReason
-                )
+    loop toUnregister keep
+        -- If any new packages were added to the unregister Map, we
+        -- need to loop through the remaining packages again to detect
+        -- if a transitive dependency is being unregistered.
+        | usAnyAdded us = loop (usToUnregister us) (usKeep us)
+        -- Nothing added, so we've already caught them all. Return the
+        -- Map we've already calculated.
+        | otherwise = usToUnregister us
+      where
+        -- Run the unregister checking function on all packages we
+        -- currently think we'll be keeping.
+        us = execState (mapM_ go keep) UnregisterState
+            { usToUnregister = toUnregister
+            , usKeep = []
+            , usAnyAdded = False
+            }
+
+    go dp = do
+        us <- get
+        case go' (usToUnregister us) ident deps of
+            -- Not unregistering, add it to the keep list
+            Nothing -> put us { usKeep = dp : usKeep us }
+            -- Unregistering, add it to the unregister Map and
+            -- indicate that a package was in fact added to the
+            -- unregister Map so we loop again.
+            Just reason -> put us
+                { usToUnregister = Map.insert gid (ident, reason) (usToUnregister us)
+                , usAnyAdded = True
+                }
+      where
+        gid = dpGhcPkgId dp
+        ident = dpPackageIdent dp
+        deps = dpDepends dp
+
+    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 undefined $ 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"
+      -- Check if a dependency is going to be unregistered
+      | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps
+          = Just $ "Dependency being unregistered: " <> packageIdentifierText dep
+      -- None of the above, keep it!
+      | otherwise = Nothing
       where
         name = packageIdentifierName ident
 

src/Stack/Build/Execute.hs

@@ -140,11 +140,11 @@ printPlan plan = do
         [] -> $logInfo "No packages would be unregistered."
         xs -> do
             $logInfo "Would unregister locally:"
-            forM_ xs $ \(ident, mreason) -> $logInfo $ T.concat
+            forM_ xs $ \(ident, reason) -> $logInfo $ T.concat
                 [ T.pack $ packageIdentifierString ident
-                , case mreason of
-                    Nothing -> ""
-                    Just reason -> T.concat
+                , if T.null reason
+                    then ""
+                    else T.concat
                         [ " ("
                         , reason
                         , ")"
@@ -591,13 +591,13 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
         [] -> return ()
         ids -> do
             localDB <- packageDatabaseLocal
-            forM_ ids $ \(id', (ident, mreason)) -> do
+            forM_ ids $ \(id', (ident, reason)) -> do
                 $logInfo $ T.concat
                     [ T.pack $ packageIdentifierString ident
                     , ": unregistering"
-                    , case mreason of
-                        Nothing -> ""
-                        Just reason -> T.concat
+                    , if T.null reason
+                        then ""
+                        else T.concat
                             [ " ("
                             , reason
                             , ")"

src/Stack/Types/Build.hs

@@ -447,7 +447,7 @@ data Plan = Plan
     { planTasks :: !(Map PackageName Task)
     , planFinals :: !(Map PackageName Task)
     -- ^ Final actions to be taken (test, benchmark, etc)
-    , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Maybe Text))
+    , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text))
     -- ^ Text is reason we're unregistering, for display only
     , planInstallExes :: !(Map Text InstallLocation)
     -- ^ Executables that should be installed after successful building