Merge pull request #6049 from commercialhaskell/fix6046

Fix #6046 Unregister local packages for sub libraries

Author: mpilgrem

ChangeLog.md

@@ -36,6 +36,9 @@ Bug fixes:
 * `stack build` with `--file-watch` or `--file-watch-poll` outputs 'pretty'
   error messages, as intended. See
   [#5978](https://github.com/commercialhaskell/stack/issues/5978).
+* `stack build` unregisters any local packages for the sub libraries of a local
+  package that is to be unregistered. See
+  [#6046](https://github.com/commercialhaskell/stack/issues/6046).
 
 ## v2.9.3
 

src/Stack/Build/ConstructPlan.hs

@@ -9,7 +9,6 @@ module Stack.Build.ConstructPlan
   ) where
 
 import           Control.Monad.RWS.Strict hiding ( (<>) )
-import           Control.Monad.State.Strict ( execState )
 import qualified Data.List as L
 import qualified Data.Map.Strict as M
 import qualified Data.Map.Strict as Map
@@ -21,6 +20,7 @@ import           Distribution.Types.PackageName ( mkPackageName )
 import           Generics.Deriving.Monoid ( memptydefault, mappenddefault )
 import           Path ( parent )
 import           RIO.Process ( HasProcessContext (..), findExecutable )
+import           RIO.State ( State, execState )
 import           Stack.Build.Cache ( tryGetFlagCache )
 import           Stack.Build.Haddock ( shouldHaddockDeps )
 import           Stack.Build.Source ( loadLocalPackage )
@@ -363,7 +363,7 @@ data UnregisterState = UnregisterState
   }
 
 -- | Determine which packages to unregister based on the given tasks and
--- already registered local packages
+-- already registered local packages.
 mkUnregisterLocal ::
      Map PackageName Task
      -- ^ Tasks
@@ -376,12 +376,18 @@ mkUnregisterLocal ::
      -- unregister target packages.
   -> Map GhcPkgId (PackageIdentifier, Text)
 mkUnregisterLocal tasks dirtyReason localDumpPkgs 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
-  -- it.
+  -- 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
+  loop ::
+       Map GhcPkgId (PackageIdentifier, Text)
+       -- ^ Current local packages to unregister.
+    -> [DumpPackage]
+       -- ^ Current local packages to keep.
+    -> Map GhcPkgId (PackageIdentifier, Text)
+       -- ^ Revised local packages to unregister.
   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
@@ -393,43 +399,71 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps =
    where
     -- Run the unregister checking function on all packages we currently think
     -- we'll be keeping.
-    us = execState (mapM_ go keep) UnregisterState
+    us = execState (mapM_ go keep) initialUnregisterState
+    initialUnregisterState = UnregisterState
       { usToUnregister = toUnregister
       , usKeep = []
       , usAnyAdded = False
       }
 
+  go :: DumpPackage -> State UnregisterState ()
   go dp = do
     us <- get
-    case go' (usToUnregister us) ident deps of
-      -- Not unregistering, add it to the keep list
+    case maybeUnregisterReason (usToUnregister us) ident mParentLibId 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.
+      -- 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
+    mParentLibId = dpParentLibIdent dp
     deps = dpDepends dp
 
-  go' toUnregister ident deps
-    -- If we're planning on running a task on it, then it must be 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
+  maybeUnregisterReason ::
+       Map GhcPkgId (PackageIdentifier, Text)
+       -- ^ Current local packages to unregister.
+    -> PackageIdentifier
+       -- ^ Package identifier.
+    -> Maybe PackageIdentifier
+       -- ^ If package for sub library, package identifier of the parent.
+    -> [GhcPkgId]
+       -- ^ Dependencies of the package.
+    -> Maybe Text
+       -- ^ If to be unregistered, the reason for doing so.
+  maybeUnregisterReason toUnregister ident mParentLibId deps
+    -- If the package is not for a sub library, then it is directly relevant. If
+    -- it is, then the relevant package is the parent. If we are planning on
+    -- running a task on the relevant package, then the package must be
+    -- unregistered, unless it is a target and an initial-build-steps build is
+    -- being done.
+    | Just task <- Map.lookup relevantPkgName tasks =
+        if    initialBuildSteps
+           && taskIsTarget task
+           && taskProvides task == relevantPkgId
+          then Nothing
+          else Just $ fromMaybe "" $ Map.lookup relevantPkgName dirtyReason
     -- Check if a dependency is going to be unregistered
-    | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps
-        = Just $ "Dependency being unregistered: " <> T.pack (packageIdentifierString dep)
+    | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps =
+        Just $ "Dependency being unregistered: "
+          <> T.pack (packageIdentifierString dep)
     -- None of the above, keep it!
     | otherwise = Nothing
     where
-      name :: PackageName
-      name = pkgName ident
+      -- If the package is not for a sub library, then the relevant package
+      -- identifier is that of the package. If it is, then the relevant package
+      -- identifier is that of the parent.
+      relevantPkgId :: PackageIdentifier
+      relevantPkgId = fromMaybe ident mParentLibId
+      -- If the package is not for a sub library, then the relevant package name
+      -- is that of the package. If it is, then the relevant package name is
+      -- that of the parent.
+      relevantPkgName :: PackageName
+      relevantPkgName = maybe (pkgName ident) pkgName mParentLibId
 
 -- | Given a 'LocalPackage' and its 'lpTestBench', adds a 'Task' for running its
 -- tests and benchmarks.

src/Stack/Types/Config.hs

@@ -2335,17 +2335,27 @@ newtype GhcPkgExe
 getGhcPkgExe :: HasCompiler env => RIO env GhcPkgExe
 getGhcPkgExe = view $ compilerPathsL.to cpPkg
 
--- | Dump information for a single package
+-- | Type representing dump information for a single package, as output by the
+-- @ghc-pkg describe@ command.
 data DumpPackage = DumpPackage
   { dpGhcPkgId :: !GhcPkgId
+    -- ^ The @id@ field.
   , dpPackageIdent :: !PackageIdentifier
+    -- ^ The @name@ and @version@ fields. The @name@ field is the munged package
+    -- name. If the package is not for a sub library, its munged name is its
+    -- name.
   , dpParentLibIdent :: !(Maybe PackageIdentifier)
+    -- ^ The @package-name@ and @version@ fields, if @package-name@ is present.
+    -- That field is present if the package is for a sub library.
   , dpLicense :: !(Maybe C.License)
   , dpLibDirs :: ![FilePath]
+    -- ^ The @library-dirs@ field.
   , dpLibraries :: ![Text]
+    -- ^ The @hs-libraries@ field.
   , dpHasExposedModules :: !Bool
   , dpExposedModules :: !(Set ModuleName)
   , dpDepends :: ![GhcPkgId]
+    -- ^ The @depends@ field (packages on which this package depends).
   , dpHaddockInterfaces :: ![FilePath]
   , dpHaddockHtml :: !(Maybe FilePath)
   , dpIsExposed :: !Bool

test/integration/tests/6046-missing-sublib-unregister/Main.hs

@@ -0,0 +1,12 @@
+import StackTest
+
+-- This tests building a package with a library and an internal sub library,
+-- where the library depends on the sub library, first version 0.1.0.0 (the
+-- Cabal file is @foo.cabal1@) and then version 0.2.0.0 (the Cabal file is
+-- @foo.cabal2@).
+main :: IO ()
+main = do
+  copy "foo.cabal1" "foo.cabal"
+  stack ["build"]
+  copy "foo.cabal2" "foo.cabal"
+  stack ["build"]

test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal1

@@ -0,0 +1,27 @@
+cabal-version: 2.0
+name:           foo
+version:        0.1.0.0
+build-type:     Simple
+
+library
+  exposed-modules:
+      Lib
+  other-modules:
+      Sub
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+  build-depends:
+      base >=4.7 && <5
+    , sub
+  default-language: Haskell2010
+
+library sub
+  exposed-modules:
+      Sub
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+  build-depends:
+      base >=4.7 && <5
+  default-language: Haskell2010

test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal2

@@ -0,0 +1,27 @@
+cabal-version: 2.0
+name:           foo
+version:        0.2.0.0
+build-type:     Simple
+
+library
+  exposed-modules:
+      Lib
+  other-modules:
+      Sub
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+  build-depends:
+      base >=4.7 && <5
+    , sub
+  default-language: Haskell2010
+
+library sub
+  exposed-modules:
+      Sub
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+  build-depends:
+      base >=4.7 && <5
+  default-language: Haskell2010

test/integration/tests/6046-missing-sublib-unregister/files/src/Lib.hs

@@ -0,0 +1,5 @@
+module Lib
+    ( someFunc
+    ) where
+
+import Sub ( someFunc )

test/integration/tests/6046-missing-sublib-unregister/files/src/Sub.hs

@@ -0,0 +1,6 @@
+module Sub
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

test/integration/tests/6046-missing-sublib-unregister/files/stack.yaml

@@ -0,0 +1 @@
+resolver: lts-20.8