Merge pull request haskell#7413 from haskell/T6358

Fix haskell#6835 (instantiating a Hackage indefinite package with an inplace package doesn't work)

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 ->

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
 

cabal-testsuite/PackageTests/Backpack/T6385/Go.hs

@@ -0,0 +1 @@
+module Go where

cabal-testsuite/PackageTests/Backpack/T6385/Go2.hs

@@ -0,0 +1 @@
+module Go2 where

cabal-testsuite/PackageTests/Backpack/T6385/Hole.hsig

@@ -0,0 +1 @@
+signature Hole where

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

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

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

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-<GHCVER> -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 = <Data.Map>
+for indef-0.1.0.0..
+Installing library in <PATH>
+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 = <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..

cabal-testsuite/PackageTests/Backpack/T6385/cabal.project

@@ -0,0 +1 @@
+packages: . alt-containers

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"]

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)

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

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