diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 862a1deca8c..077c6422be4 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 @@ -1797,6 +1798,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 +2143,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 +2201,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 +2253,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 +2302,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 +2328,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..0388886ecde 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,13 @@ data BuildStyle = instance Binary BuildStyle instance Structured BuildStyle +instance Semigroup BuildStyle where + BuildInplaceOnly <> _ = BuildInplaceOnly + _ <> BuildInplaceOnly = BuildInplaceOnly + _ <> _ = BuildAndInstall +instance Monoid BuildStyle where + mempty = BuildAndInstall + mappend = (<>) type CabalFileText = LBS.ByteString diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/Go.hs b/cabal-testsuite/PackageTests/Backpack/T6385/Go.hs new file mode 100644 index 00000000000..c7acd84e487 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/Go.hs @@ -0,0 +1 @@ +module Go where diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/Go2.hs b/cabal-testsuite/PackageTests/Backpack/T6385/Go2.hs new file mode 100644 index 00000000000..6d6af8f027b --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/Go2.hs @@ -0,0 +1 @@ +module Go2 where diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/Hole.hsig b/cabal-testsuite/PackageTests/Backpack/T6385/Hole.hsig new file mode 100644 index 00000000000..6e7629d4e30 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/Hole.hsig @@ -0,0 +1 @@ +signature Hole where diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/T6385.cabal b/cabal-testsuite/PackageTests/Backpack/T6385/T6385.cabal new file mode 100644 index 00000000000..31e20f559ed --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/T6385.cabal @@ -0,0 +1,17 @@ +name: T6385 +version: 1.0 +build-type: Simple +cabal-version: 2.0 + +library top-def + default-language: Haskell2010 + build-depends: base, indef, alt-containers + hs-source-dirs: . + exposed-modules: Go + +library top-indef + default-language: Haskell2010 + build-depends: base, indef, alt-containers + hs-source-dirs: . + signatures: Hole + exposed-modules: Go2 diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs b/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs new file mode 100644 index 00000000000..4d2e8f207a9 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/Data/Map.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RoleAnnotations #-} +module Data.Map where +type role Map nominal representational +data Map k a = Map +instance Functor (Map k) where + fmap _ Map = Map diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/alt-containers.cabal b/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/alt-containers.cabal new file mode 100644 index 00000000000..116f9fb14e4 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/alt-containers/alt-containers.cabal @@ -0,0 +1,10 @@ +name: alt-containers +version: 1.0 +build-type: Simple +cabal-version: 2.0 + +library + default-language: Haskell2010 + build-depends: base + hs-source-dirs: . + exposed-modules: Data.Map diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/cabal.out b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.out new file mode 100644 index 00000000000..2ec73aebf3f --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.out @@ -0,0 +1,33 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - alt-containers-1.0 (lib) (first run) + - indef-0.1.0.0 (lib) (requires build) + - indef-0.1.0.0 (lib with Data.Map=alt-containers-1.0-inplace:Data.Map) (requires build) + - T6385-1.0 (lib:top-indef) (first run) + - T6385-1.0 (lib:top-def) (first run) +Configuring library for alt-containers-1.0.. +Preprocessing library for alt-containers-1.0.. +Building library for alt-containers-1.0.. +Configuring library for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +Installing library in +Configuring library instantiated with + Data.Map = alt-containers-1.0-inplace:Data.Map +for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with + Data.Map = alt-containers-1.0-inplace:Data.Map +for indef-0.1.0.0.. +Configuring library 'top-indef' for T6385-1.0.. +Preprocessing library 'top-indef' for T6385-1.0.. +Building library 'top-indef' instantiated with Hole = +for T6385-1.0.. +Configuring library 'top-def' for T6385-1.0.. +Preprocessing library 'top-def' for T6385-1.0.. +Building library 'top-def' for T6385-1.0.. diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/cabal.project b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.project new file mode 100644 index 00000000000..576a5108863 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.project @@ -0,0 +1 @@ +packages: . alt-containers diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs new file mode 100644 index 00000000000..1555552cd08 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = withShorterPathForNewBuildStore $ \storeDir -> + cabalTest $ do + skipUnlessGhcVersion ">= 8.1" + skipIfWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + withRepo "repo" $ do + cabalG ["--store-dir=" ++ storeDir] "v2-build" ["T6385"] diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Data/Map.hsig b/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Data/Map.hsig new file mode 100644 index 00000000000..997ec1aa576 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Data/Map.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +signature Data.Map where +type role Map nominal representational +data Map k a +instance Functor (Map k) diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Foo.hs b/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Foo.hs new file mode 100644 index 00000000000..5be3e4b85b0 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +import Data.Map + +f :: (a -> b) -> Map k a -> Map k b +f = fmap diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/indef.cabal b/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/indef.cabal new file mode 100644 index 00000000000..bd0f5f5e003 --- /dev/null +++ b/cabal-testsuite/PackageTests/Backpack/T6385/repo/indef-0.1.0.0/indef.cabal @@ -0,0 +1,13 @@ +name: indef +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: 2.0 + +library + build-depends: base + signatures: Data.Map + exposed-modules: Foo + default-language: Haskell2010