From 7bbcc9f63e2390f416242fbb84e2112b4f6374a2 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Tue, 31 Jan 2023 20:35:34 +0000 Subject: [PATCH] Fix #6046 Unregister local packages for sub libraries Also adds documentation. Also adds an integration test. --- ChangeLog.md | 3 + src/Stack/Build/ConstructPlan.hs | 78 +++++++++++++------ src/Stack/Types/Config.hs | 12 ++- .../6046-missing-sublib-unregister/Main.hs | 12 +++ .../files/foo.cabal1 | 27 +++++++ .../files/foo.cabal2 | 27 +++++++ .../files/src/Lib.hs | 5 ++ .../files/src/Sub.hs | 6 ++ .../files/stack.yaml | 1 + 9 files changed, 148 insertions(+), 23 deletions(-) create mode 100644 test/integration/tests/6046-missing-sublib-unregister/Main.hs create mode 100644 test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal1 create mode 100644 test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal2 create mode 100644 test/integration/tests/6046-missing-sublib-unregister/files/src/Lib.hs create mode 100644 test/integration/tests/6046-missing-sublib-unregister/files/src/Sub.hs create mode 100644 test/integration/tests/6046-missing-sublib-unregister/files/stack.yaml diff --git a/ChangeLog.md b/ChangeLog.md index 7ebffeeb81..2d6065cea4 100644 --- a/ChangeLog.md +++ b/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 diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 96d0ce4e0e..e4e801bba5 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/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,19 +399,21 @@ 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 @@ -413,23 +421,49 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps = 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. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index e696f098a5..5026a528a0 100644 --- a/src/Stack/Types/Config.hs +++ b/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 diff --git a/test/integration/tests/6046-missing-sublib-unregister/Main.hs b/test/integration/tests/6046-missing-sublib-unregister/Main.hs new file mode 100644 index 0000000000..174dad3876 --- /dev/null +++ b/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"] diff --git a/test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal1 b/test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal1 new file mode 100644 index 0000000000..f6cf35e216 --- /dev/null +++ b/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 diff --git a/test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal2 b/test/integration/tests/6046-missing-sublib-unregister/files/foo.cabal2 new file mode 100644 index 0000000000..58cd271816 --- /dev/null +++ b/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 diff --git a/test/integration/tests/6046-missing-sublib-unregister/files/src/Lib.hs b/test/integration/tests/6046-missing-sublib-unregister/files/src/Lib.hs new file mode 100644 index 0000000000..7bce5cbb19 --- /dev/null +++ b/test/integration/tests/6046-missing-sublib-unregister/files/src/Lib.hs @@ -0,0 +1,5 @@ +module Lib + ( someFunc + ) where + +import Sub ( someFunc ) diff --git a/test/integration/tests/6046-missing-sublib-unregister/files/src/Sub.hs b/test/integration/tests/6046-missing-sublib-unregister/files/src/Sub.hs new file mode 100644 index 0000000000..a173e7a513 --- /dev/null +++ b/test/integration/tests/6046-missing-sublib-unregister/files/src/Sub.hs @@ -0,0 +1,6 @@ +module Sub + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/integration/tests/6046-missing-sublib-unregister/files/stack.yaml b/test/integration/tests/6046-missing-sublib-unregister/files/stack.yaml new file mode 100644 index 0000000000..570867cbb5 --- /dev/null +++ b/test/integration/tests/6046-missing-sublib-unregister/files/stack.yaml @@ -0,0 +1 @@ +resolver: lts-20.8