Commit 8fa4d2ea authored by Edward Z. Yang's avatar Edward Z. Yang Committed by GitHub
Browse files

Merge pull request #3672 from ezyang/backpack

Backpack
parents f8095ac4 cf7e3313
# trivial gitignore file
.cabal-sandbox/
cabal.sandbox.config
cabal.project.local
cabal-dev/
.hpc/
*.hi
......
......@@ -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
......
{-# 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]
-- | 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] ]
{-# 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:
--