Merge pull request #8726 from mpickering/wip/no-configure

Add support for loading multiple components into one repl session

Author: mergify[bot]

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -29,7 +29,7 @@ tests = testGroup "Distribution.Utils.Structured"
     , testCase "GenericPackageDescription" $
       md5Check (Proxy :: Proxy GenericPackageDescription) 0xa3e9433662ecf0c7a3c26f6d75a53ba1
     , testCase "LocalBuildInfo" $
-      md5Check (Proxy :: Proxy LocalBuildInfo) 0x91ffcd61bbd83525e8edba877435a031
+      md5Check (Proxy :: Proxy LocalBuildInfo) 0x30ebb8fffa1af2aefa9432ff4028eef8
 #endif
     ]
 

Cabal/src/Distribution/Backpack/Configure.hs

@@ -46,6 +46,7 @@ import Distribution.Verbosity
 import qualified Distribution.Compat.Graph as Graph
 import Distribution.Compat.Graph (Graph, IsNode(..))
 import Distribution.Utils.LogProgress
+import Distribution.Backpack.ModuleShape
 
 import Data.Either
     ( lefts )
@@ -66,15 +67,15 @@ configureComponentLocalBuildInfos
     -> Flag String            -- configIPID
     -> Flag ComponentId       -- configCID
     -> PackageDescription
-    -> [PreExistingComponent]
+    -> ([PreExistingComponent], [PromisedComponent])
     -> FlagAssignment         -- configConfigurationsFlags
     -> [(ModuleName, Module)] -- configInstantiateWith
     -> InstalledPackageIndex
     -> Compiler
     -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
 configureComponentLocalBuildInfos
     verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr
-    prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do
+    (prePkgDeps, promisedPkgDeps) flagAssignment instantiate_with installedPackageSet comp = do
     -- NB: In single component mode, this returns a *single* component.
     -- In this graph, the graph is NOT closed.
     graph0 <- case mkComponentsGraph enabled pkg_descr of
@@ -92,6 +93,10 @@ configureComponentLocalBuildInfos
                                 ann_cname = pc_compname pkg
                               }))
             | pkg <- prePkgDeps]
+            `Map.union`
+            Map.fromListWith Map.union
+            [ (pkg, Map.singleton (ann_cname aid) aid)
+            | PromisedComponent pkg aid <- promisedPkgDeps]
     graph1 <- toConfiguredComponents use_external_internal_deps
                     flagAssignment
                     deterministic ipid_flag cid_flag pkg_descr
@@ -102,13 +107,19 @@ configureComponentLocalBuildInfos
     let shape_pkg_map = Map.fromList
             [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))
             | pkg <- prePkgDeps]
+            `Map.union`
+            Map.fromList
+            [ (ann_id aid, (DefiniteUnitId (unsafeMkDefUnitId
+                            (mkUnitId (unComponentId (ann_id aid) )))
+                           ,  emptyModuleShape))
+            | PromisedComponent _ aid <- promisedPkgDeps]
         uid_lookup def_uid
             | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid
             = FullUnitId (Installed.installedComponentId pkg)
                  (Map.fromList (Installed.instantiatedWith pkg))
             | otherwise = error ("uid_lookup: " ++ prettyShow uid)
           where uid = unDefUnitId def_uid
-    graph2 <- toLinkedComponents verbosity uid_lookup
+    graph2 <- toLinkedComponents verbosity (not (null promisedPkgDeps)) uid_lookup
                     (package pkg_descr) shape_pkg_map graph1
 
     infoProgress $
@@ -129,7 +140,7 @@ configureComponentLocalBuildInfos
     infoProgress $ hang (text "Ready component graph:") 4
                         (vcat (map dispReadyComponent graph4))
 
-    toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4
+    toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4
 
 ------------------------------------------------------------------------------
 -- ComponentLocalBuildInfo
@@ -138,13 +149,14 @@ configureComponentLocalBuildInfos
 toComponentLocalBuildInfos
     :: Compiler
     -> InstalledPackageIndex -- FULL set
+    -> [PromisedComponent]
     -> PackageDescription
     -> [PreExistingComponent] -- external package deps
     -> [ReadyComponent]
     -> LogProgress ([ComponentLocalBuildInfo],
                     InstalledPackageIndex) -- only relevant packages
 toComponentLocalBuildInfos
-    comp installedPackageSet pkg_descr externalPkgDeps graph = do
+    comp installedPackageSet promisedPkgDeps pkg_descr externalPkgDeps graph = do
     -- Check and make sure that every instantiated component exists.
     -- We have to do this now, because prior to linking/instantiating
     -- we don't actually know what the full set of 'UnitId's we need
@@ -178,9 +190,15 @@ toComponentLocalBuildInfos
         --
         packageDependsIndex = PackageIndex.fromList (lefts local_graph)
         fullIndex = Graph.fromDistinctList local_graph
+
     case Graph.broken fullIndex of
         [] -> return ()
-        broken ->
+        -- If there are promised dependencies, we don't know what the dependencies
+        -- of these are and that can easily lead to a broken graph. So assume that
+        -- any promised package is not broken (ie all its dependencies, transitively,
+        -- will be there). That's a promise.
+        broken | not (null promisedPkgDeps) -> return ()
+               | otherwise ->
           -- TODO: ppr this
           dieProgress . text $
                 "The following packages are broken because other"

Cabal/src/Distribution/Backpack/ConfiguredComponent.hs

@@ -177,22 +177,22 @@ toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do
         if newPackageDepsBehaviour pkg_descr
             then fmap concat $ forM (targetBuildDepends bi) $
                  \(Dependency name _ sublibs) -> do
-                    pkg <- case Map.lookup name lib_dep_map of
+                    case Map.lookup name lib_dep_map of
                         Nothing ->
                             dieProgress $
                                 text "Dependency on unbuildable" <+>
                                 text "package" <+> pretty name
-                        Just p -> return p
-                    -- Return all library components
-                    forM (NonEmptySet.toList sublibs) $ \lib ->
-                        let comp = CLibName lib in
-                        case Map.lookup comp pkg of
-                            Nothing ->
-                                dieProgress $
-                                    text "Dependency on unbuildable" <+>
-                                    text (showLibraryName lib) <+>
-                                    text "from" <+> pretty name
-                            Just v -> return v
+                        Just pkg -> do
+                          -- Return all library components
+                         forM (NonEmptySet.toList sublibs) $ \lib ->
+                             let comp = CLibName lib in
+                             case Map.lookup comp pkg of
+                                 Nothing ->
+                                     dieProgress $
+                                         text "Dependency on unbuildable" <+>
+                                         text (showLibraryName lib) <+>
+                                         text "from" <+> pretty name
+                                 Just v -> return v
             else return old_style_lib_deps
     mkConfiguredComponent
        pkg_descr this_cid

Cabal/src/Distribution/Backpack/LinkedComponent.hs

@@ -114,12 +114,13 @@ instance Package LinkedComponent where
 
 toLinkedComponent
     :: Verbosity
+    -> Bool -- ^ Whether there are any "promised" package dependencies which we won't find already installed.
     -> FullDb
     -> PackageId
     -> LinkedComponentMap
     -> ConfiguredComponent
     -> LogProgress LinkedComponent
-toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
+toLinkedComponent verbosity anyPromised db this_pid pkg_map ConfiguredComponent {
     cc_ann_id = aid@AnnotatedId { ann_id = this_cid },
     cc_component = component,
     cc_exe_deps = exe_deps,
@@ -276,9 +277,14 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
           case filter (\x' -> unWithSource x /= unWithSource x') xs of
             [] -> return ()
             _ -> Left $ ambiguousReexportMsg reex x xs
-          return (to, unWithSource x)
+          return (to, Just (unWithSource x))
         _ ->
-          Left (brokenReexportMsg reex)
+          -- Can't resolve it right now.. carry on with the assumption it will be resolved
+          -- dynamically later by an in-memory package which hasn't been installed yet.
+          if anyPromised
+            then return (to, Nothing)
+            -- But if nothing is promised, eagerly report an error, as we already know everything.
+            else Left (brokenReexportMsg reex)
 
     -- TODO: maybe check this earlier; it's syntactically obvious.
     let build_reexports m (k, v)
@@ -289,8 +295,27 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
     provs <- foldM build_reexports Map.empty $
                 -- TODO: doublecheck we have checked for
                 -- src_provs duplicates already!
-                [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++
-                reexports_list
+                -- These are normal module exports.
+                [ (mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs ]
+                ++
+                 -- These are reexports, which we managed to resolve to something in an external package.
+                 [(mn_new, om) | (mn_new, Just om) <- reexports_list ]
+                ++
+                -- These ones.. we didn't resolve but also we might not have to
+                -- resolve them because they could come from a promised unit,
+                -- which we don't know anything about yet. GHC will resolve
+                -- these itself when it is dealing with the multi-session.
+                -- These ones will not be built, registered and put
+                -- into a package database, we only need them to make it as far
+                -- as generating GHC options where the info will be used to
+                -- pass the reexported-module option to GHC.
+
+                -- We also know that in the case there are promised units that
+                -- we will not be doing anything to do with backpack like
+                -- unification etc..
+                 [ (mod_name, OpenModule (DefiniteUnitId (unsafeMkDefUnitId
+                                          (mkUnitId "fake"))) mod_name)
+                 | (mod_name, Nothing) <- reexports_list ]
 
     let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape))
 
@@ -337,20 +362,22 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
 -- every ComponentId gets converted into a UnitId by way of SimpleUnitId.
 toLinkedComponents
     :: Verbosity
+    -> Bool -- ^ Whether there are any "promised" package dependencies which we won't
+            -- find already installed.
     -> FullDb
     -> PackageId
     -> LinkedComponentMap
     -> [ConfiguredComponent]
     -> LogProgress [LinkedComponent]
-toLinkedComponents verbosity db this_pid lc_map0 comps
+toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps
    = fmap snd (mapAccumM go lc_map0 comps)
  where
   go :: Map ComponentId (OpenUnitId, ModuleShape)
      -> ConfiguredComponent
      -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)
   go lc_map cc = do
     lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $
-            toLinkedComponent verbosity db this_pid lc_map cc
+            toLinkedComponent verbosity anyPromised db this_pid lc_map cc
     return (extendLinkedComponentMap lc lc_map, lc)
 
 type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape)

Cabal/src/Distribution/Backpack/PreExistingComponent.hs

@@ -1,6 +1,7 @@
 -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
 module Distribution.Backpack.PreExistingComponent (
     PreExistingComponent(..),
+    PromisedComponent(..),
     ipiToPreExistingComponent,
 ) where
 
@@ -20,6 +21,21 @@ import Distribution.Package
 import qualified Data.Map as Map
 import qualified Distribution.InstalledPackageInfo as Installed
 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import Distribution.Types.AnnotatedId
+
+-- | A /promised/ component.
+--
+-- These components are promised to @configure@ but are not yet built.
+--
+-- In other words this is 'PreExistingComponent' which doesn't yet exist.
+--
+data PromisedComponent = PromisedComponent
+    { pr_pkgname :: PackageName
+    , pr_cid     :: AnnotatedId ComponentId
+    }
+
+instance Package PromisedComponent where
+  packageId = packageId . pr_cid
 
 -- | Stripped down version of 'LinkedComponent' for things
 -- we don't need to know how to build.

Cabal/src/Distribution/Compat/ResponseFile.hs

@@ -3,7 +3,7 @@
 -- Compatibility layer for GHC.ResponseFile
 -- Implementation from base 4.12.0 is used.
 -- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE
-module Distribution.Compat.ResponseFile (expandResponse) where
+module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where
 
 import Distribution.Compat.Prelude
 import Prelude ()
@@ -13,7 +13,7 @@ import System.IO (hPutStrLn, stderr)
 import System.IO.Error
 
 #if MIN_VERSION_base(4,12,0)
-import GHC.ResponseFile (unescapeArgs)
+import GHC.ResponseFile (unescapeArgs, escapeArgs)
 #else
 
 unescapeArgs :: String -> [String]
@@ -47,6 +47,20 @@ unescape args = reverse . map reverse $ go args NoneQ False [] []
         | '"'  == c              = go cs DblQ  False a     as
         | otherwise              = go cs NoneQ False (c:a) as
 
+escapeArgs :: [String] -> String
+escapeArgs = unlines . map escapeArg
+
+escapeArg :: String -> String
+escapeArg = reverse . foldl' escape []
+
+escape :: String -> Char -> String
+escape cs c
+  |    isSpace c
+    || '\\' == c
+    || '\'' == c
+    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
+  | otherwise    = c:cs
+
 #endif
 
 expandResponse :: [String] -> IO [String]