Merge pull request #3672 from ezyang/backpack

Backpack

.gitignore

 # trivial gitignore file
 .cabal-sandbox/
 cabal.sandbox.config
+cabal.project.local
 cabal-dev/
 .hpc/
 *.hi

Cabal/Cabal.cabal

@@ -40,6 +40,15 @@ extra-source-files:
   tests/PackageTests/AllowOlder/benchmarks/Bench.hs
   tests/PackageTests/AllowOlder/src/Foo.hs
   tests/PackageTests/AllowOlder/tests/Test.hs
+  tests/PackageTests/Ambiguity/p/Dupe.hs
+  tests/PackageTests/Ambiguity/p/p.cabal
+  tests/PackageTests/Ambiguity/package-import/A.hs
+  tests/PackageTests/Ambiguity/package-import/package-import.cabal
+  tests/PackageTests/Ambiguity/q/Dupe.hs
+  tests/PackageTests/Ambiguity/q/q.cabal
+  tests/PackageTests/Ambiguity/reexport-test/Main.hs
+  tests/PackageTests/Ambiguity/reexport-test/reexport-test.cabal
+  tests/PackageTests/Ambiguity/reexport/reexport.cabal
   tests/PackageTests/AutogenModules/Package/Dummy.hs
   tests/PackageTests/AutogenModules/Package/MyBenchModule.hs
   tests/PackageTests/AutogenModules/Package/MyExeModule.hs
@@ -54,6 +63,44 @@ extra-source-files:
   tests/PackageTests/AutogenModules/SrcDist/MyLibrary.hs
   tests/PackageTests/AutogenModules/SrcDist/MyTestModule.hs
   tests/PackageTests/AutogenModules/SrcDist/my.cabal
+  tests/PackageTests/Backpack/Includes1/A.hs
+  tests/PackageTests/Backpack/Includes1/B.hs
+  tests/PackageTests/Backpack/Includes1/Includes1.cabal
+  tests/PackageTests/Backpack/Includes2/Includes2.cabal
+  tests/PackageTests/Backpack/Includes2/exe/Main.hs
+  tests/PackageTests/Backpack/Includes2/exe/exe.cabal
+  tests/PackageTests/Backpack/Includes2/fail.cabal
+  tests/PackageTests/Backpack/Includes2/mylib/Mine.hs
+  tests/PackageTests/Backpack/Includes2/mylib/mylib.cabal
+  tests/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs
+  tests/PackageTests/Backpack/Includes2/mysql/mysql.cabal
+  tests/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs
+  tests/PackageTests/Backpack/Includes2/postgresql/postgresql.cabal
+  tests/PackageTests/Backpack/Includes2/src/App.hs
+  tests/PackageTests/Backpack/Includes2/src/src.cabal
+  tests/PackageTests/Backpack/Includes3/Includes3.cabal
+  tests/PackageTests/Backpack/Includes3/exe/Main.hs
+  tests/PackageTests/Backpack/Includes3/exe/exe.cabal
+  tests/PackageTests/Backpack/Includes3/indef/Foo.hs
+  tests/PackageTests/Backpack/Includes3/indef/indef.cabal
+  tests/PackageTests/Backpack/Includes3/sigs/sigs.cabal
+  tests/PackageTests/Backpack/Includes4/Includes4.cabal
+  tests/PackageTests/Backpack/Includes4/Main.hs
+  tests/PackageTests/Backpack/Includes4/impl/A.hs
+  tests/PackageTests/Backpack/Includes4/impl/B.hs
+  tests/PackageTests/Backpack/Includes4/impl/Rec.hs
+  tests/PackageTests/Backpack/Includes4/indef/C.hs
+  tests/PackageTests/Backpack/Includes5/A.hs
+  tests/PackageTests/Backpack/Includes5/B.hs
+  tests/PackageTests/Backpack/Includes5/Includes5.cabal
+  tests/PackageTests/Backpack/Includes5/impl/Foobar.hs
+  tests/PackageTests/Backpack/Includes5/impl/Quxbaz.hs
+  tests/PackageTests/Backpack/Indef1/Indef1.cabal
+  tests/PackageTests/Backpack/Indef1/Provide.hs
+  tests/PackageTests/Backpack/Reexport1/p/P.hs
+  tests/PackageTests/Backpack/Reexport1/p/p.cabal
+  tests/PackageTests/Backpack/Reexport1/q/Q.hs
+  tests/PackageTests/Backpack/Reexport1/q/q.cabal
   tests/PackageTests/BenchmarkExeV10/Foo.hs
   tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs
   tests/PackageTests/BenchmarkExeV10/my.cabal
@@ -207,6 +254,13 @@ extra-source-files:
   tests/PackageTests/PreProcessExtraSources/Foo.hsc
   tests/PackageTests/PreProcessExtraSources/Main.hs
   tests/PackageTests/PreProcessExtraSources/my.cabal
+  tests/PackageTests/ReexportedModules/containers-dupe/Data/Map.hs
+  tests/PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal
+  tests/PackageTests/ReexportedModules/p/Private.hs
+  tests/PackageTests/ReexportedModules/p/Public.hs
+  tests/PackageTests/ReexportedModules/p/fail-ambiguous.cabal
+  tests/PackageTests/ReexportedModules/p/fail-missing.cabal
+  tests/PackageTests/ReexportedModules/p/fail-other.cabal
   tests/PackageTests/ReexportedModules/p/p.cabal
   tests/PackageTests/ReexportedModules/q/A.hs
   tests/PackageTests/ReexportedModules/q/q.cabal
@@ -310,6 +364,16 @@ library
                  -Wnoncanonical-monadfail-instances
 
   exposed-modules:
+    Distribution.Backpack
+    Distribution.Backpack.Configure
+    Distribution.Backpack.ComponentsGraph
+    Distribution.Backpack.ConfiguredComponent
+    Distribution.Backpack.FullUnitId
+    Distribution.Backpack.LinkedComponent
+    Distribution.Backpack.ModSubst
+    Distribution.Backpack.ModuleShape
+    Distribution.Utils.LogProgress
+    Distribution.Utils.MapAccum
     Distribution.Compat.CreatePipe
     Distribution.Compat.Environment
     Distribution.Compat.Exception
@@ -395,6 +459,7 @@ library
     Distribution.Types.Library
     Distribution.Types.ModuleReexport
     Distribution.Types.ModuleRenaming
+    Distribution.Types.IncludeRenaming
     Distribution.Types.SetupBuildInfo
     Distribution.Types.TestSuite
     Distribution.Types.TestSuiteInterface
@@ -411,12 +476,21 @@ library
     Distribution.Types.TargetInfo
     Distribution.Utils.NubList
     Distribution.Utils.ShortText
+    Distribution.Utils.Progress
     Distribution.Verbosity
     Distribution.Version
     Language.Haskell.Extension
     Distribution.Compat.Binary
 
   other-modules:
+    Distribution.Backpack.PreExistingComponent
+    Distribution.Backpack.ReadyComponent
+    Distribution.Backpack.MixLink
+    Distribution.Backpack.ModuleScope
+    Distribution.Backpack.UnifyM
+    Distribution.Backpack.Id
+    Distribution.Utils.UnionFind
+    Distribution.Utils.Base62
     Distribution.Compat.CopyFile
     Distribution.Compat.GetShortPathName
     Distribution.Compat.MonadFail

Cabal/Distribution/Backpack.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | This module defines the core data types for Backpack.  For more
+-- details, see:
+--
+--  <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
+
+module Distribution.Backpack (
+    -- * OpenUnitId
+    OpenUnitId(..),
+    openUnitIdComponentId,
+    openUnitIdFreeHoles,
+    mkOpenUnitId,
+
+    -- * DefUnitId
+    DefUnitId,
+    unDefUnitId,
+    mkDefUnitId,
+
+    -- * OpenModule
+    OpenModule(..),
+    openModuleFreeHoles,
+
+    -- * OpenModuleSubst
+    OpenModuleSubst,
+    dispOpenModuleSubst,
+    dispOpenModuleSubstEntry,
+    parseOpenModuleSubst,
+    parseOpenModuleSubstEntry,
+    openModuleSubstFreeHoles,
+
+    -- * Conversions to 'UnitId'
+    abstractUnitId,
+    hashModuleSubst,
+) where
+
+import Prelude ()
+import Distribution.Compat.Prelude hiding (mod)
+import Distribution.Compat.ReadP
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint (hcat)
+
+import Distribution.ModuleName
+import Distribution.Package
+import Distribution.Text
+import Distribution.Utils.Base62
+
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-----------------------------------------------------------------------
+-- OpenUnitId
+
+-- | An 'OpenUnitId' describes a (possibly partially) instantiated
+-- Backpack component, with a description of how the holes are filled
+-- in.  Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured
+-- form that allows for substitution (which fills in holes.) This form
+-- of unit cannot be installed. It must first be converted to a
+-- 'UnitId'.
+--
+-- In the absence of Backpack, there are no holes to fill, so any such
+-- component always has an empty module substitution; thus we can lossly
+-- represent it as an 'OpenUnitId uid'.
+--
+-- For a source component using Backpack, however, there is more
+-- structure as components may be parametrized over some signatures, and
+-- these \"holes\" may be partially or wholly filled.
+--
+-- OpenUnitId plays an important role when we are mix-in linking,
+-- and is recorded to the installed packaged database for indefinite
+-- packages; however, for compiled packages that are fully instantiated,
+-- we instantiate 'OpenUnitId' into 'UnitId'.
+--
+-- For more details see the Backpack spec
+-- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
+--
+
+data OpenUnitId
+    -- | Identifies a component which may have some unfilled holes;
+    -- specifying its 'ComponentId' and its 'OpenModuleSubst'.
+    -- TODO: Invariant that 'OpenModuleSubst' is non-empty?
+    -- See also the Text instance.
+    = IndefFullUnitId ComponentId OpenModuleSubst
+    -- | Identifies a fully instantiated component, which has
+    -- been compiled and abbreviated as a hash.  The embedded 'UnitId'
+    -- MUST NOT be for an indefinite component; an 'OpenUnitId'
+    -- is guaranteed not to have any holes.
+    | DefiniteUnitId DefUnitId
+  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+-- TODO: cache holes?
+
+instance Binary OpenUnitId
+
+instance NFData OpenUnitId where
+    rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst
+    rnf (DefiniteUnitId uid) = rnf uid
+
+instance Text OpenUnitId where
+    disp (IndefFullUnitId cid insts)
+        -- TODO: arguably a smart constructor to enforce invariant would be
+        -- better
+        | Map.null insts = disp cid
+        | otherwise      = disp cid <<>> Disp.brackets (dispOpenModuleSubst insts)
+    disp (DefiniteUnitId uid) = disp uid
+    parse = parseOpenUnitId <++ fmap DefiniteUnitId parse
+      where
+        parseOpenUnitId = do
+            cid <- parse
+            insts <- Parse.between (Parse.char '[') (Parse.char ']')
+                       parseOpenModuleSubst
+            return (IndefFullUnitId cid insts)
+
+-- | Get the 'ComponentId' of an 'OpenUnitId'.
+openUnitIdComponentId :: OpenUnitId -> ComponentId
+openUnitIdComponentId (IndefFullUnitId cid _) = cid
+openUnitIdComponentId (DefiniteUnitId def_uid) = unitIdComponentId (unDefUnitId def_uid)
+
+-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
+openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
+openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts
+openUnitIdFreeHoles _ = Set.empty
+
+-- | Safe constructor from a UnitId.  The only way to do this safely
+-- is if the instantiation is provided.
+mkOpenUnitId :: UnitId -> OpenModuleSubst -> OpenUnitId
+mkOpenUnitId uid insts =
+    if Set.null (openModuleSubstFreeHoles insts)
+        then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!
+        else IndefFullUnitId (unitIdComponentId uid) insts
+
+-----------------------------------------------------------------------
+-- DefUnitId
+
+-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
+-- with no holes.
+mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
+mkDefUnitId cid insts =
+    unsafeMkDefUnitId (UnitId cid (hashModuleSubst insts)) -- impose invariant!
+
+-----------------------------------------------------------------------
+-- OpenModule
+
+-- | Unlike a 'Module', an 'OpenModule' is either an ordinary
+-- module from some unit, OR an 'OpenModuleVar', representing a
+-- hole that needs to be filled in.  Substitutions are over
+-- module variables.
+data OpenModule
+    = OpenModule OpenUnitId ModuleName
+    | OpenModuleVar ModuleName
+  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+
+instance Binary OpenModule
+
+instance NFData OpenModule where
+    rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name
+    rnf (OpenModuleVar mod_name) = rnf mod_name
+
+instance Text OpenModule where
+    disp (OpenModule uid mod_name) =
+        hcat [disp uid, Disp.text ":", disp mod_name]
+    disp (OpenModuleVar mod_name) =
+        hcat [Disp.char '<', disp mod_name, Disp.char '>']
+    parse = parseModuleVar <++ parseOpenModule
+      where
+        parseOpenModule = do
+            uid <- parse
+            _ <- Parse.char ':'
+            mod_name <- parse
+            return (OpenModule uid mod_name)
+        parseModuleVar = do
+            _ <- Parse.char '<'
+            mod_name <- parse
+            _ <- Parse.char '>'
+            return (OpenModuleVar mod_name)
+
+-- | Get the set of holes ('ModuleVar') embedded in a 'Module'.
+openModuleFreeHoles :: OpenModule -> Set ModuleName
+openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name
+openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid
+
+-----------------------------------------------------------------------
+-- OpenModuleSubst
+
+-- | An explicit substitution on modules.
+--
+-- NB: These substitutions are NOT idempotent, for example, a
+-- valid substitution is (A -> B, B -> A).
+type OpenModuleSubst = Map ModuleName OpenModule
+
+-- | Pretty-print the entries of a module substitution, suitable
+-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@.
+dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc
+dispOpenModuleSubst subst
+    = Disp.hcat
+    . Disp.punctuate Disp.comma
+    $ map dispOpenModuleSubstEntry (Map.toAscList subst)
+
+-- | Pretty-print a single entry of a module substitution.
+dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc
+dispOpenModuleSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v
+
+-- | Inverse to 'dispModSubst'.
+parseOpenModuleSubst :: ReadP r OpenModuleSubst
+parseOpenModuleSubst = fmap Map.fromList
+      . flip Parse.sepBy (Parse.char ',')
+      $ parseOpenModuleSubstEntry
+
+-- | Inverse to 'dispModSubstEntry'.
+parseOpenModuleSubstEntry :: ReadP r (ModuleName, OpenModule)
+parseOpenModuleSubstEntry =
+    do k <- parse
+       _ <- Parse.char '='
+       v <- parse
+       return (k, v)
+
+-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.
+-- This is NOT the domain of the substitution.
+openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName
+openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts))
+
+-----------------------------------------------------------------------
+-- Conversions to UnitId
+
+-- | When typechecking, we don't demand that a freshly instantiated
+-- 'IndefFullUnitId' be compiled; instead, we just depend on the
+-- installed indefinite unit installed at the 'ComponentId'.
+abstractUnitId :: OpenUnitId -> UnitId
+abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid
+abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid
+
+-- | Take a module substitution and hash it into a string suitable for
+-- 'UnitId'.  Note that since this takes 'Module', not 'OpenModule',
+-- you are responsible for recursively converting 'OpenModule'
+-- into 'Module'.  See also "Distribution.Backpack.ReadyComponent".
+hashModuleSubst :: Map ModuleName Module -> Maybe String
+hashModuleSubst subst
+  | Map.null subst = Nothing
+  | otherwise =
+      Just . hashToBase62 $
+        concat [ display mod_name ++ "=" ++ display m ++ "\n"
+               | (mod_name, m) <- Map.toList subst]

Cabal/Distribution/Backpack/ComponentsGraph.hs

+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
+
+module Distribution.Backpack.ComponentsGraph (
+    ComponentsGraph,
+    dispComponentsGraph,
+    toComponentsGraph,
+    componentCycleMsg
+) where
+
+import Distribution.Package
+import Distribution.PackageDescription as PD hiding (Flag)
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Types.ComponentRequestedSpec
+import Distribution.Simple.Utils
+import Distribution.Compat.Graph (Node(..))
+import qualified Distribution.Compat.Graph as Graph
+
+import Distribution.Text
+    ( Text(disp) )
+import Text.PrettyPrint
+
+------------------------------------------------------------------------------
+-- Components graph
+------------------------------------------------------------------------------
+
+-- | A components graph is a source level graph tracking the
+-- dependencies between components in a package.
+type ComponentsGraph = [(Component, [ComponentName])]
+
+-- | Pretty-print a 'ComponentsGraph'.
+dispComponentsGraph :: ComponentsGraph -> Doc
+dispComponentsGraph graph =
+    vcat [ hang (text "component" <+> disp (componentName c)) 4
+                (vcat [ text "dependency" <+> disp cdep | cdep <- cdeps ])
+         | (c, cdeps) <- graph ]
+
+-- | Given the package description and a 'PackageDescription' (used
+-- to determine if a package name is internal or not), create a graph of
+-- dependencies between the components.  This is NOT necessarily the
+-- build order (although it is in the absence of Backpack.)
+toComponentsGraph :: ComponentRequestedSpec
+                  -> PackageDescription
+                  -> Either [ComponentName] ComponentsGraph
+toComponentsGraph enabled pkg_descr =
+    let g = Graph.fromList [ N c (componentName c) (componentDeps c)
+                           | c <- pkgBuildableComponents pkg_descr
+                           , componentEnabled enabled c ]
+    in case Graph.cycles g of
+          []     -> Right (map (\(N c _ cs) -> (c, cs)) (Graph.revTopSort g))
+          ccycles -> Left  [ componentName c | N c _ _ <- concat ccycles ]
+  where
+    -- The dependencies for the given component
+    componentDeps component =
+         [ CExeName toolname | Dependency pkgname _
+                               <- buildTools bi
+                             , let toolname = unPackageName pkgname
+                             , toolname `elem` map exeName
+                               (executables pkg_descr) ]
+
+      ++ [ if pkgname == packageName pkg_descr
+            then CLibName
+            else CSubLibName toolname
+            | Dependency pkgname _
+                               <- targetBuildDepends bi
+                             , pkgname `elem` internalPkgDeps
+            , let toolname = unPackageName pkgname ]
+      where
+        bi = componentBuildInfo component
+        internalPkgDeps = map (conv . libName) (allLibraries pkg_descr)
+        conv Nothing = packageName pkg_descr
+        conv (Just s) = mkPackageName s
+
+-- | Error message when there is a cycle; takes the SCC of components.
+componentCycleMsg :: [ComponentName] -> Doc
+componentCycleMsg cnames =
+    text $ "Components in the package depend on each other in a cyclic way:\n  "
+       ++ intercalate " depends on "
+            [ "'" ++ showComponentName cname ++ "'"
+            | cname <- cnames ++ [head cnames] ]

Cabal/Distribution/Backpack/Configure.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonoLocalBinds #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+
+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
+--
+-- WARNING: The contents of this module are HIGHLY experimental.
+-- We may refactor it under you.
+module Distribution.Backpack.Configure (
+    configureComponentLocalBuildInfos,
+) where
+
+import Prelude ()
+import Distribution.Compat.Prelude hiding ((<>))
+
+import Distribution.Backpack
+import Distribution.Backpack.FullUnitId
+import Distribution.Backpack.PreExistingComponent
+import Distribution.Backpack.ConfiguredComponent
+import Distribution.Backpack.LinkedComponent
+import Distribution.Backpack.ReadyComponent
+import Distribution.Backpack.ComponentsGraph
+
+import Distribution.Simple.Compiler hiding (Flag)
+import Distribution.Package
+import qualified Distribution.InstalledPackageInfo as Installed
+import Distribution.InstalledPackageInfo (InstalledPackageInfo
+                                         ,emptyInstalledPackageInfo)
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import Distribution.PackageDescription as PD hiding (Flag)
+import Distribution.ModuleName
+import Distribution.Simple.Setup as Setup
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Types.ComponentRequestedSpec
+import Distribution.Verbosity
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.Compat.Graph (Graph, IsNode(..))
+import Distribution.Utils.Progress
+import Distribution.Utils.LogProgress
+
+import Data.Either
+    ( lefts )
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Distribution.Text
+    ( display )
+import Text.PrettyPrint
+
+------------------------------------------------------------------------------
+-- Pipeline
+------------------------------------------------------------------------------
+
+configureComponentLocalBuildInfos
+    :: Verbosity
+    -> Bool                   -- use_external_internal_deps
+    -> ComponentRequestedSpec
+    -> Flag String            -- configIPID
+    -> Flag ComponentId       -- configCID
+    -> PackageDescription
+    -> [PreExistingComponent]
+    -> FlagAssignment         -- configConfigurationsFlags
+    -> [(ModuleName, Module)] -- configInstantiateWith
+    -> InstalledPackageIndex
+    -> Compiler
+    -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
+configureComponentLocalBuildInfos
+    verbosity use_external_internal_deps enabled ipid_flag cid_flag pkg_descr
+    prePkgDeps 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 toComponentsGraph enabled pkg_descr of
+                Left ccycle -> failProgress (componentCycleMsg ccycle)
+                Right comps -> return comps
+    infoProgress $ hang (text "Source component graph:") 4
+                        (dispComponentsGraph graph0)
+
+    let conf_pkg_map = Map.fromList
+            [(pc_pkgname pkg, (pc_cid pkg, pc_pkgid pkg))
+            | pkg <- prePkgDeps]
+        graph1 = toConfiguredComponents use_external_internal_deps
+                    flagAssignment
+                    ipid_flag cid_flag pkg_descr
+                    conf_pkg_map (map fst graph0)
+    infoProgress $ hang (text "Configured component graph:") 4
+                        (vcat (map dispConfiguredComponent graph1))
+
+    let shape_pkg_map = Map.fromList
+            [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))
+            | pkg <- prePkgDeps]
+        uid_lookup def_uid
+            | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid
+            = FullUnitId (Installed.installedComponentId pkg)
+                 (Map.fromList (Installed.instantiatedWith pkg))
+            | otherwise = error ("uid_lookup: " ++ display uid)
+          where uid = unDefUnitId def_uid
+    graph2 <- toLinkedComponents verbosity uid_lookup
+                    (package pkg_descr) shape_pkg_map graph1
+
+    infoProgress $
+        hang (text "Linked component graph:") 4
+             (vcat (map dispLinkedComponent graph2))
+
+    let pid_map = Map.fromList $
+            [ (pc_cid pkg, pc_pkgid pkg)
+            | pkg <- prePkgDeps] ++
+            [ (Installed.installedComponentId pkg, Installed.sourcePackageId pkg)
+            | (_, Module uid _) <- instantiate_with
+            , Just pkg <- [PackageIndex.lookupUnitId
+                                installedPackageSet (unDefUnitId uid)] ] ++
+            [ (lc_cid lc, lc_pkgid lc)
+            | lc <- graph2 ]
+        subst = Map.fromList instantiate_with
+        graph3 = toReadyComponents pid_map subst graph2
+        graph4 = Graph.revTopSort (Graph.fromList graph3)
+
+    infoProgress $ hang (text "Ready component graph:") 4
+                        (vcat (map dispReadyComponent graph4))
+
+    toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4
+
+------------------------------------------------------------------------------
+-- ComponentLocalBuildInfo
+------------------------------------------------------------------------------
+
+toComponentLocalBuildInfos
+    :: Compiler
+    -> InstalledPackageIndex -- FULL set
+    -> PackageDescription
+    -> [PreExistingComponent] -- external package deps
+    -> [ReadyComponent]
+    -> LogProgress ([ComponentLocalBuildInfo],
+                    InstalledPackageIndex) -- only relevant packages
+toComponentLocalBuildInfos
+    comp installedPackageSet 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
+    -- are.
+    let -- TODO: This is actually a bit questionable performance-wise,
+        -- since we will pay for the ALL installed packages even if
+        -- they are not related to what we are building.  This was true
+        -- in the old configure code.
+        external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
+        external_graph = Graph.fromList
+                       . map Left
+                       $ PackageIndex.allPackages installedPackageSet
+        internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
+        internal_graph = Graph.fromList
+                       . map Right
+                       $ graph
+        combined_graph = Graph.unionRight external_graph internal_graph
+        Just local_graph = Graph.closure combined_graph (map nodeKey graph)
+        -- The database of transitively reachable installed packages that the
+        -- external components the package (as a whole) depends on.  This will be
+        -- used in several ways:
+        --