Skip to content

Commit 14bc45d

Browse files
andreabediniandreabedini
committed
fix: rewrite instantiateInstallPlan
1 parent 37bb792 commit 14bc45d

File tree

1 file changed

+137
-107
lines changed

1 file changed

+137
-107
lines changed

‎cabal-install/src/Distribution/Client/ProjectPlanning.hs‎

Lines changed: 137 additions & 107 deletions
Original file line numberDiff line numberDiff line change
@@ -206,7 +206,7 @@ import Distribution.Types.PackageVersionConstraint
206206
import Distribution.Types.PkgconfigDependency
207207
import Distribution.Types.UnqualComponentName
208208

209-
import Distribution.Backpack
209+
import Distribution.Backpack hiding (mkDefUnitId)
210210
import Distribution.Backpack.ComponentsGraph
211211
import Distribution.Backpack.ConfiguredComponent
212212
import Distribution.Backpack.FullUnitId
@@ -231,7 +231,7 @@ import qualified Distribution.Compat.Graph as Graph
231231
import Control.Exception (assert)
232232
import Control.Monad (sequence)
233233
import Control.Monad.IO.Class (liftIO)
234-
import Control.Monad.State as State (State, execState, runState, state)
234+
import Control.Monad.State (State, execState, gets, modify)
235235
import Data.Foldable (fold)
236236
import Data.List (deleteBy, groupBy)
237237
import qualified Data.List.NonEmpty as NE
@@ -2783,7 +2783,7 @@ binDirectories layout config package = case elabBuildStyle package of
27832783
distBuildDirectory layout (elabDistDirParams config package)
27842784
</> "build"
27852785

2786-
type InstS = Map UnitId ElaboratedPlanPackage
2786+
type InstS = Map (WithStage UnitId) ElaboratedPlanPackage
27872787
type InstM a = State InstS a
27882788

27892789
getComponentId
@@ -2867,118 +2867,141 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
28672867
(Graph.fromDistinctList (Map.elems ready_map))
28682868
where
28692869
pkgs = InstallPlan.toList plan
2870-
2871-
cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs]
2870+
2871+
cmap = Map.fromList [(WithStage (stageOf pkg) (getComponentId pkg), pkg) | pkg <- pkgs]
28722872

28732873
instantiateUnitId
2874-
:: ComponentId
2874+
:: Stage
2875+
-> ComponentId
2876+
-- ^ The id of the component being instantiated
28752877
-> Map ModuleName (Module, BuildStyle)
2878+
-- ^ A mapping from module names (the "holes" or signatures in Backpack)
2879+
-- to the concrete modules (and their build styles) that should fill those
2880+
-- holes.
28762881
-> InstM (DefUnitId, BuildStyle)
2877-
instantiateUnitId cid insts = state $ \s ->
2878-
case Map.lookup uid s of
2879-
Nothing ->
2880-
-- Knot tied
2881-
-- TODO: I don't think the knot tying actually does
2882-
-- anything useful
2883-
let (r, s') =
2884-
runState
2885-
(instantiateComponent uid cid insts)
2886-
(Map.insert uid r s)
2887-
in ((def_uid, extractElabBuildStyle r), Map.insert uid r s')
2888-
Just r -> ((def_uid, extractElabBuildStyle r), s)
2882+
instantiateUnitId stage cid insts =
2883+
gets (Map.lookup (WithStage stage uid)) >>= \case
2884+
Nothing -> do
2885+
r <- instantiateComponent uid (WithStage stage cid) insts
2886+
modify (Map.insert (WithStage stage uid) r)
2887+
return (unsafeMkDefUnitId uid, extractElabBuildStyle r)
2888+
Just r ->
2889+
return (unsafeMkDefUnitId uid, extractElabBuildStyle r)
28892890
where
2890-
def_uid = mkDefUnitId cid (fmap fst insts)
2891-
uid = unDefUnitId def_uid
2891+
uid = mkDefUnitId cid (fmap fst insts)
28922892

28932893
-- No need to InplaceT; the inplace-ness is properly computed for
28942894
-- the ElaboratedPlanPackage, so that will implicitly pass it on
28952895
instantiateComponent
28962896
:: UnitId
2897-
-> ComponentId
2897+
-- ^ The unit id to assign to the instantiated component
2898+
-> WithStage ComponentId
2899+
-- ^ The id of the component being instantiated
28982900
-> Map ModuleName (Module, BuildStyle)
2901+
-- ^ A mapping from module names (the "holes" or signatures in Backpack)
2902+
-- to the concrete modules (and their build styles) that should fill those
2903+
-- holes.
28992904
-> InstM ElaboratedPlanPackage
2900-
instantiateComponent uid cid insts
2901-
| Just planpkg <- Map.lookup cid cmap =
2905+
instantiateComponent uid cidws@(WithStage stage cid) insts =
2906+
case Map.lookup cidws cmap of
2907+
Nothing -> error ("instantiateComponent: " ++ prettyShow cid)
2908+
Just planpkg ->
29022909
case planpkg of
2903-
InstallPlan.Configured
2904-
( elab0@ElaboratedConfiguredPackage
2905-
{ elabPkgOrComp = ElabComponent comp
2906-
}
2907-
) -> do
2908-
deps <-
2909-
traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp)
2910-
let build_style = fold (fmap snd insts)
2911-
let getDep (Module dep_uid _) = [dep_uid]
2912-
elab1 =
2913-
fixupBuildStyle build_style $
2914-
elab0
2915-
{ elabUnitId = uid
2916-
, elabComponentId = cid
2917-
, elabIsCanonical = Map.null (fmap fst insts)
2918-
, elabPkgOrComp =
2919-
ElabComponent
2920-
comp
2921-
{ compOrderLibDependencies =
2922-
(if Map.null insts then [] else [newSimpleUnitId cid])
2923-
++ ordNub
2924-
( map
2925-
unDefUnitId
2926-
(deps ++ concatMap (getDep . fst) (Map.elems insts))
2927-
)
2928-
, compInstantiatedWith = fmap fst insts
2929-
}
2910+
InstallPlan.Installed{} -> return planpkg
2911+
InstallPlan.PreExisting{} -> return planpkg
2912+
InstallPlan.Configured elab0 ->
2913+
case elabPkgOrComp elab0 of
2914+
ElabPackage{} -> return planpkg
2915+
ElabComponent comp -> do
2916+
deps <- traverse (fmap fst . instantiateUnit stage insts) (compLinkedLibDependencies comp)
2917+
let build_style = fold (fmap snd insts)
2918+
let getDep (Module dep_uid _) = [dep_uid]
2919+
elab1 =
2920+
fixupBuildStyle build_style $
2921+
elab0
2922+
{ elabUnitId = uid
2923+
, elabComponentId = cid
2924+
, elabIsCanonical = Map.null (fmap fst insts)
2925+
, elabPkgOrComp =
2926+
ElabComponent
2927+
comp
2928+
{ compOrderLibDependencies =
2929+
(if Map.null insts then [] else [newSimpleUnitId cid])
2930+
++ ordNub
2931+
( map
2932+
unDefUnitId
2933+
(deps ++ concatMap (getDep . fst) (Map.elems insts))
2934+
)
2935+
, compInstantiatedWith = fmap fst insts
2936+
}
2937+
}
2938+
return $ InstallPlan.Configured
2939+
elab1
2940+
{ elabInstallDirs =
2941+
computeInstallDirs
2942+
storeDirLayout
2943+
defaultInstallDirs
2944+
elaboratedShared
2945+
elab1
29302946
}
2931-
elab =
2932-
elab1
2933-
{ elabInstallDirs =
2934-
computeInstallDirs
2935-
storeDirLayout
2936-
defaultInstallDirs
2937-
elaboratedShared
2938-
elab1
2939-
}
2940-
return $ InstallPlan.Configured elab
2941-
_ -> return planpkg
2942-
| otherwise = error ("instantiateComponent: " ++ prettyShow cid)
29432947

2944-
substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle)
2945-
substUnitId _ (DefiniteUnitId uid) =
2948+
-- | Instantiates an OpenUnitId into a concrete UnitId, producing a concrete UnitId and its associated BuildStyle.
2949+
--
2950+
-- This function recursively applies a module substitution to an OpenUnitId, producing a fully instantiated
2951+
-- (definite) unit and its build style. This is a key step in Backpack-style instantiation, where "holes" in
2952+
-- a package are filled with concrete modules.
2953+
--
2954+
-- Behavior
2955+
--
2956+
-- If given a DefiniteUnitId, it returns the id and a default build style (BuildAndInstall).
2957+
--
2958+
-- If given an IndefFullUnitId, it:
2959+
-- Recursively applies the substitution to each module in the instantiation map using substSubst.
2960+
-- Calls instantiateUnitId to create or retrieve the fully instantiated unit id and build style for this instantiation.
2961+
--
2962+
instantiateUnit
2963+
:: Stage
2964+
-> Map ModuleName (Module, BuildStyle)
2965+
-- ^ A mapping from module names to their corresponding modules and build styles.
2966+
-> OpenUnitId
2967+
-- ^ The unit to instantiate. This can be:
2968+
-- DefiniteUnitId uid: already fully instantiated (no holes).
2969+
-- IndefFullUnitId cid insts: an indefinite unit (with holes), described by a component id and a mapping of holes to modules.
2970+
-> InstM (DefUnitId, BuildStyle)
2971+
instantiateUnit _stage _subst (DefiniteUnitId def_uid) =
29462972
-- This COULD actually, secretly, be an inplace package, but in
29472973
-- that case it doesn't matter as it's already been recorded
29482974
-- in the package that depends on this
2949-
return (uid, BuildAndInstall)
2950-
substUnitId subst (IndefFullUnitId cid insts) = do
2951-
insts' <- substSubst subst insts
2952-
instantiateUnitId cid insts'
2953-
2954-
-- NB: NOT composition
2955-
substSubst
2956-
:: Map ModuleName (Module, BuildStyle)
2957-
-> Map ModuleName OpenModule
2958-
-> InstM (Map ModuleName (Module, BuildStyle))
2959-
substSubst subst insts = traverse (substModule subst) insts
2960-
2961-
substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle)
2962-
substModule subst (OpenModuleVar mod_name)
2975+
return (def_uid, BuildAndInstall)
2976+
instantiateUnit stage subst (IndefFullUnitId cid insts) = do
2977+
insts' <- traverse (instantiateModule stage subst) insts
2978+
instantiateUnitId stage cid insts'
2979+
2980+
-- | Instantiates an OpenModule into a concrete Module producing a concrete Module
2981+
-- and its associated BuildStyle.
2982+
instantiateModule
2983+
:: Stage
2984+
-> Map ModuleName (Module, BuildStyle)
2985+
-- ^ A mapping from module names to their corresponding modules and build styles.
2986+
-> OpenModule
2987+
-- ^ The module to substitute, which can be:
2988+
-- OpenModuleVar mod_name: a hole (variable) named mod_name
2989+
-- OpenModule uid mod_name: a module from a specific unit (uid).
2990+
-> InstM (Module, BuildStyle)
2991+
instantiateModule _stage subst (OpenModuleVar mod_name)
29632992
| Just m <- Map.lookup mod_name subst = return m
29642993
| otherwise = error "substModule: non-closing substitution"
2965-
substModule subst (OpenModule uid mod_name) = do
2966-
(uid', build_style) <- substUnitId subst uid
2994+
instantiateModule stage subst (OpenModule uid mod_name) = do
2995+
(uid', build_style) <- instantiateUnit stage subst uid
29672996
return (Module uid' mod_name, build_style)
29682997

2969-
indefiniteUnitId :: ComponentId -> InstM UnitId
2970-
indefiniteUnitId cid = do
2971-
let uid = newSimpleUnitId cid
2972-
r <- indefiniteComponent uid cid
2973-
state $ \s -> (uid, Map.insert uid r s)
2974-
2975-
indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage
2976-
indefiniteComponent _uid cid
2977-
-- Only need Configured; this phase happens before improvement, so
2978-
-- there shouldn't be any Installed packages here.
2979-
| Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap
2980-
, ElabComponent elab_comp <- elabPkgOrComp epkg =
2981-
do
2998+
indefiniteComponent
2999+
:: ElaboratedConfiguredPackage
3000+
-> InstM ElaboratedConfiguredPackage
3001+
indefiniteComponent epkg =
3002+
case elabPkgOrComp epkg of
3003+
ElabPackage{} -> return epkg
3004+
ElabComponent elab_comp -> do
29823005
-- We need to do a little more processing of the includes: some
29833006
-- of them are fully definite even without substitution. We
29843007
-- want to build those too; see #5634.
@@ -2996,13 +3019,13 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
29963019
-- DefiniteUnitId (that's what substUnitId does!)
29973020
new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->
29983021
if Set.null (openUnitIdFreeHoles uid)
2999-
then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid)
3022+
then fmap (DefiniteUnitId . fst) (instantiateUnit (elabStage epkg) Map.empty uid)
30003023
else return uid
30013024
-- NB: no fixupBuildStyle needed here, as if the indefinite
30023025
-- component depends on any inplace packages, it itself must
30033026
-- be indefinite! There is no substitution here, we can't
30043027
-- post facto add inplace deps
3005-
return . InstallPlan.Configured $
3028+
return
30063029
epkg
30073030
{ elabPkgOrComp =
30083031
ElabComponent
@@ -3018,31 +3041,38 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
30183041
++ [unDefUnitId d | DefiniteUnitId d <- new_deps]
30193042
}
30203043
}
3021-
| Just planpkg <- Map.lookup cid cmap =
3022-
return planpkg
3023-
| otherwise = error ("indefiniteComponent: " ++ prettyShow cid)
30243044

30253045
fixupBuildStyle BuildAndInstall elab = elab
3026-
fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab
3027-
fixupBuildStyle t@(BuildInplaceOnly{}) elab =
3046+
fixupBuildStyle _buildStyle (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab
3047+
fixupBuildStyle buildStyle@(BuildInplaceOnly{}) elab =
30283048
elab
3029-
{ elabBuildStyle = t
3049+
{ elabBuildStyle = buildStyle
30303050
, elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab
30313051
, elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab
30323052
, elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab
30333053
}
30343054

30353055
ready_map = execState work Map.empty
3036-
30373056
work = for_ pkgs $ \pkg ->
30383057
case pkg of
30393058
InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp=ElabComponent comp})
3040-
| not (Map.null (compLinkedInstantiatedWith comp)) ->
3041-
indefiniteUnitId (elabComponentId elab)
3042-
>> return ()
3059+
| not (Map.null (compLinkedInstantiatedWith comp)) -> do
3060+
r <- indefiniteComponent elab
3061+
modify (Map.insert (WithStage (elabStage elab) (elabUnitId elab)) (InstallPlan.Configured r))
30433062
_ ->
3044-
instantiateUnitId (getComponentId pkg) Map.empty
3045-
>> return ()
3063+
void $ instantiateUnitId (stageOf pkg) (getComponentId pkg) Map.empty
3064+
3065+
-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
3066+
-- with no holes.
3067+
--
3068+
-- This function is defined in Cabal-syntax but only cabal-install
3069+
-- cares about it so I am putting it here.
3070+
--
3071+
-- I am also not using the DefUnitId newtype since I believe it
3072+
-- provides little value in the code above.
3073+
mkDefUnitId :: ComponentId -> Map ModuleName Module -> UnitId
3074+
mkDefUnitId cid insts =
3075+
mkUnitId (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts))
30463076

30473077
---------------------------
30483078
-- Build targets

0 commit comments

Comments
 (0)