From 29c701c154cafa4844cf3c1bd4a93cacfa6b1ee1 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Wed, 15 Jan 2020 17:48:30 +0100
Subject: Refactor package related code

The package terminology is a bit of a mess. Cabal packages contain
components. Instances of these components when built with some
flags/options/dependencies are called units. Units are registered into
package databases and their metadata are called PackageConfig.

GHC only knows about package databases containing units. It is a sad
mismatch not fixed by this patch (we would have to rename parameters
such as `package-id <unit-id>` which would affect users).

This patch however fixes the following internal names:

- Renames PackageConfig into UnitInfo.
- Rename systemPackageConfig into globalPackageDatabase[Path]
- Rename PkgConfXX into PkgDbXX
- Rename pkgIdMap into unitIdMap
- Rename ModuleToPkgDbAll into ModuleNameProvidersMap
- Rename lookupPackage into lookupUnit
- Add comments on DynFlags package related fields

It also introduces a new `PackageDatabase` datatype instead of
explicitly passing the following tuple: `(FilePath,[PackageConfig])`.

The `pkgDatabase` field in `DynFlags` now contains the unit info for
each unit of each package database exactly as they have been read from
disk. Previously the command-line flag `-distrust-all-packages` would
modify these unit info. Now this flag only affects the "dynamic"
consolidated package state found in `pkgState` field. It makes sense
because `initPackages` could be called first with this
`distrust-all-packages` flag set and then again (using ghc-api) without
and it should work (package databases are not read again from disk when
`initPackages` is called the second time).

Bump haddock submodule
---
 compiler/backpack/BkpSyn.hs    |  2 +-
 compiler/backpack/DriverBkp.hs | 29 ++++++++++++++---------------
 2 files changed, 15 insertions(+), 16 deletions(-)

(limited to 'compiler/backpack')

diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs
index ce14018883..fcc0160899 100644
--- a/compiler/backpack/BkpSyn.hs
+++ b/compiler/backpack/BkpSyn.hs
@@ -23,7 +23,7 @@ import GHC.Hs
 import SrcLoc
 import Outputable
 import Module
-import PackageConfig
+import UnitInfo
 
 {-
 ************************************************************************
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index 0afef71bb7..e8fdba5bd3 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -190,7 +190,7 @@ withBkpSession cid insts deps session_type do_this = do
         importPaths = [],
         -- Synthesized the flags
         packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
-          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
+          let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
           in ExposePackage
             (showSDoc dflags
                 (text "-unit-id" <+> ppr uid <+> ppr rn))
@@ -271,7 +271,7 @@ buildUnit session cid insts lunit = do
 
     dflags <- getDynFlags
     -- IMPROVE IT
-    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
+    let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0
 
     mb_old_eps <- case session of
                     TcSession -> fmap Just getEpsGhc
@@ -375,20 +375,19 @@ compileExe lunit = do
         ok <- load' LoadAllTargets (Just msg) mod_graph
         when (failed ok) (liftIO $ exitWith (ExitFailure 1))
 
-addPackage :: GhcMonad m => PackageConfig -> m ()
+-- | Register a new virtual package database containing a single unit
+addPackage :: GhcMonad m => UnitInfo -> m ()
 addPackage pkg = do
-    dflags0 <- GHC.getSessionDynFlags
-    case pkgDatabase dflags0 of
+    dflags <- GHC.getSessionDynFlags
+    case pkgDatabase dflags of
         Nothing -> panic "addPackage: called too early"
-        Just pkgs -> do let dflags = dflags0 { pkgDatabase =
-                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
-                        _ <- GHC.setSessionDynFlags dflags
-                        -- By this time, the global ref has probably already
-                        -- been forced, in which case doing this isn't actually
-                        -- going to do you any good.
-                        -- dflags <- GHC.getSessionDynFlags
-                        -- liftIO $ setUnsafeGlobalDynFlags dflags
-                        return ()
+        Just dbs -> do
+         let newdb = PackageDatabase
+               { packageDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"
+               , packageDatabaseUnits = [pkg]
+               }
+         _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) })
+         return ()
 
 -- Precondition: UnitId is NOT InstalledUnitId
 compileInclude :: Int -> (Int, UnitId) -> BkpM ()
@@ -397,7 +396,7 @@ compileInclude n (i, uid) = do
     let dflags = hsc_dflags hsc_env
     msgInclude (i, n) uid
     -- Check if we've compiled it already
-    case lookupPackage dflags uid of
+    case lookupUnit dflags uid of
         Nothing -> do
             case splitUnitIdInsts uid of
                 (_, Just indef) ->
-- 
cgit v1.2.1