From 35aa1fa7e2c9a21abe0c9239ac230be42ed48ddc Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 31 May 2021 01:14:34 -0400 Subject: [PATCH] Fix #6835 Fixes the bug by accurately tracking when instantiations refer to inplace packages, and adjusting previously non-inplace packages to be inplace when this occurs. See comment in ProjectPlanning.hs for more details. Signed-off-by: Edward Z. Yang (cherry picked from commit 823e894983ce8a9545ce30d7f93cf09dceca35d2) --- .../Distribution/Client/ProjectPlanning.hs | 123 ++++++++++++++---- .../Client/ProjectPlanning/Types.hs | 10 ++ 2 files changed, 110 insertions(+), 23 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 445bf48e42d..a975927e450 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -157,6 +157,7 @@ import Distribution.Version import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph(IsNode(..)) +import Data.Foldable (fold) import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) import qualified Text.PrettyPrint as Disp import qualified Data.Map as Map @@ -663,7 +664,9 @@ rebuildInstallPlan verbosity defaultInstallDirs elaboratedShared elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + liftIO $ notice verbosity "--- Instantiated plan:" + liftIO $ noticeNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + liftIO $ notice verbosity "---" return (instantiatedPlan, elaboratedShared) where withRepoCtx = projectConfigWithSolverRepoContext verbosity @@ -1797,6 +1800,10 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB elabSetupScriptStyle elabPkgDescription libDepGraph deps0 elabSetupPackageDBStack = buildAndRegisterDbs + elabInplaceBuildPackageDBStack = inplacePackageDbs + elabInplaceRegisterPackageDBStack = inplacePackageDbs + elabInplaceSetupPackageDBStack = inplacePackageDbs + buildAndRegisterDbs | shouldBuildInplaceOnly pkg = inplacePackageDbs | otherwise = storePackageDbs @@ -2138,6 +2145,55 @@ getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab +extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage + -> BuildStyle +extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab +extractElabBuildStyle _ = BuildAndInstall + +-- instantiateInstallPlan is responsible for filling out an InstallPlan +-- with all of the extra Configured packages that would be generated by +-- recursively instantiating the dependencies of packages. +-- +-- Suppose we are compiling the following packages: +-- +-- unit f where +-- signature H +-- +-- unit g where +-- dependency f[H=containers:Data.Map] +-- +-- At entry, we have an InstallPlan with a single plan package per +-- actual source package, e.g., only (indefinite!) f and g. The job of +-- instantiation is to turn this into three plan packages: each of the +-- packages as before, but also a new, definite package f[H=containers:Data.Map] +-- +-- How do we do this? The general strategy is to iterate over every +-- package in the existing plan and recursively create new entries for +-- each of its dependencies which is an instantiated package (e.g., +-- f[H=p:G]). This process must be recursive, as f itself may depend on +-- OTHER packages which it instantiated using its hole H. +-- +-- Some subtleties: +-- +-- * We have to keep track of whether or not we are instantiating with +-- inplace packages, because instantiating a non-inplace package with +-- an inplace packages makes it inplace (since it depends on +-- something in the inplace store)! The rule is that if any of the +-- modules in an instantiation are inplace, then the instantiated +-- unit itself must be inplace. There is then a bunch of faffing +-- about to keep track of BuildStyle. +-- +-- * ElaboratedConfiguredPackage was never really designed for post +-- facto instantiation, so some of the steps for generating new +-- instantiations are a little fraught. For example, the act of +-- flipping a package to be inplace involves faffing about with four +-- fields, because these fields are precomputed. A good refactor +-- would be to reduce the amount of precomputation to simplify the +-- algorithm here. +-- +-- * We use the state monad to cache already instantiated modules, so +-- we don't instantiate the same thing multiple times. +-- instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new (IndependentGoals False) @@ -2147,41 +2203,46 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId + instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle) + -> InstM (DefUnitId, BuildStyle) instantiateUnitId cid insts = state $ \s -> case Map.lookup uid s of Nothing -> -- Knot tied + -- TODO: I don't think the knot tying actually does + -- anything useful let (r, s') = runState (instantiateComponent uid cid insts) (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) + in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') + Just r -> ((def_uid, extractElabBuildStyle r), s) where - def_uid = mkDefUnitId cid insts + def_uid = mkDefUnitId cid (fmap fst insts) uid = unDefUnitId def_uid + -- No need to InplaceT; the inplace-ness is properly computed for + -- the ElaboratedPlanPackage, so that will implicitly pass it on instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module + :: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle) -> InstM ElaboratedPlanPackage instantiateComponent uid cid insts | Just planpkg <- Map.lookup cid cmap = case planpkg of InstallPlan.Configured (elab0@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) -> do - deps <- traverse (substUnitId insts) - (compLinkedLibDependencies comp) + deps <- + traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) + let build_style = fold (fmap snd insts) let getDep (Module dep_uid _) = [dep_uid] - elab1 = elab0 { + elab1 = fixupBuildStyle build_style $ elab0 { elabUnitId = uid, elabComponentId = cid, - elabInstantiatedWith = insts, - elabIsCanonical = Map.null insts, + elabInstantiatedWith = fmap fst insts, + elabIsCanonical = Map.null (fmap fst insts), elabPkgOrComp = ElabComponent comp { compOrderLibDependencies = (if Map.null insts then [] else [newSimpleUnitId cid]) ++ ordNub (map unDefUnitId - (deps ++ concatMap getDep (Map.elems insts))) + (deps ++ concatMap (getDep . fst) (Map.elems insts))) } } elab = elab1 { @@ -2194,26 +2255,29 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ prettyShow cid) - substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId + substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle) substUnitId _ (DefiniteUnitId uid) = - return uid + -- This COULD actually, secretly, be an inplace package, but in + -- that case it doesn't matter as it's already been recorded + -- in the package that depends on this + return (uid, BuildAndInstall) substUnitId subst (IndefFullUnitId cid insts) = do insts' <- substSubst subst insts instantiateUnitId cid insts' -- NB: NOT composition - substSubst :: Map ModuleName Module + substSubst :: Map ModuleName (Module, BuildStyle) -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) + -> InstM (Map ModuleName (Module, BuildStyle)) substSubst subst insts = traverse (substModule subst) insts - substModule :: Map ModuleName Module -> OpenModule -> InstM Module + substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle) substModule subst (OpenModuleVar mod_name) | Just m <- Map.lookup mod_name subst = return m | otherwise = error "substModule: non-closing substitution" substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) + (uid', build_style) <- substUnitId subst uid + return (Module uid' mod_name, build_style) indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do @@ -2240,13 +2304,17 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = -- is no IndefFullUnitId in compLinkedLibDependencies that actually -- has no holes. We couldn't specify this invariant when -- we initially created the ElaboratedPlanPackage because - -- we have no way of actually refiying the UnitId into a + -- we have no way of actually reifying the UnitId into a -- DefiniteUnitId (that's what substUnitId does!) new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> if Set.null (openUnitIdFreeHoles uid) - then fmap DefiniteUnitId (substUnitId Map.empty uid) + then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid) else return uid - return $ InstallPlan.Configured epkg { + -- NB: no fixupBuildStyle needed here, as if the indefinite + -- component depends on any inplace packages, it itself must + -- be indefinite! There is no substitution here, we can't + -- post facto add inplace deps + return . InstallPlan.Configured $ epkg { elabPkgOrComp = ElabComponent elab_comp { compLinkedLibDependencies = new_deps, -- I think this is right: any new definite unit ids we @@ -2262,6 +2330,15 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = = return planpkg | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) + fixupBuildStyle BuildAndInstall elab = elab + fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab + fixupBuildStyle BuildInplaceOnly elab = elab { + elabBuildStyle = BuildInplaceOnly, + elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab, + elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab, + elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab + } + ready_map = execState work Map.empty work = for_ pkgs $ \pkg -> diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index c3e920f3e5d..64662baca7e 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -237,6 +237,10 @@ data ElaboratedConfiguredPackage elabBuildPackageDBStack :: PackageDBStack, elabRegisterPackageDBStack :: PackageDBStack, + elabInplaceSetupPackageDBStack :: PackageDBStack, + elabInplaceBuildPackageDBStack :: PackageDBStack, + elabInplaceRegisterPackageDBStack :: PackageDBStack, + elabPkgDescriptionOverride :: Maybe CabalFileText, -- TODO: make per-component variants of these flags @@ -744,6 +748,12 @@ data BuildStyle = instance Binary BuildStyle instance Structured BuildStyle +instance Semigroup BuildStyle where + BuildInplaceOnly <> _ = BuildInplaceOnly + _ <> BuildInplaceOnly = BuildInplaceOnly + _ <> _ = BuildAndInstall +instance Monoid BuildStyle where + mempty = BuildAndInstall type CabalFileText = LBS.ByteString