Commit f2840cca authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Add the bulk of the new Backpack code

This will shortly be used in the package configuration step.

    A copy of the Progress monad from cabal-install solver, which we use
    to report failure and logging from otherwise pure code.

    Defines a type class ModSubst for semantic objects that can have
    module substitutions defined over them.  Helps us define ModSubst

    A module scope represents the set of required and provided modules
    which are "in scope", i.e., available for import and mix-in linking.
    This is not a simple mapping from module name to module, as we're
    permitted to have conflicting definitions for a module name as long
    as we don't actually use it.  There's a comment which explains this
    more clearly in the file.  These are based off of 'IndefModule'
    because not all modules in scope are necessarily fully instantiated.

    A module shape describes the provisions and requirements of a
    library.  It's similar to a module scope, except that every
    export must be unambiguous; it too is based off of 'IndefModule'.

    An 'IndefUnitId' is not guaranteed to record a module substitution
    (it could be opaquely represented as a hash); a 'FullUnitId',
    however, IS guaranteed to do so.  Given, for example, an installed
    package database, we can map opaque 'UnitId' into their expanded
    representation.  This can be important to handle obscure unification
    problems when mix-in linking.

    The unification monad, unifiable variants of Module/UnitId (with
    conversions to and from), and low-level unification operations on
    them.  Uses 'UnionFind' heavily.

    There is some commented out support for handling recursive
    unification.  At present there is no surface syntax for representing
    such situations.  (We would also need DFA minimization to
    canonicalize these regular trees.)

    The actual implementation of mix-in linking, on top of the
    unification monad 'UnifyM'.  The key function is 'mixLink',
    which takes two module scopes and links them together.

    The progress monad, specialized with LogMsg traces and Doc
    errors.  We provide a function to run such computations,
    outputting traces according to their 'Verbosity' and 'die'ing
    if there is an error.

    A small helper function for handling the source-level graph
    of components (so, just the relationship between stanzas
    in a Cabal file.)  This components graph will eventually get
    elaborated into a more complex graph with instantiations, etc.

    A helper module which now contains the functions for computing
    component identifiers and compatibility package keys.  This
    functionality used to live in Distribution.Simple.Configure
    but I split it out.  There are also adjustments to handle
    the new Backpack functionality.

    A configured component is one for which we've resolved all
    source level dependencies (e.g., every entry in build-depends,
    we know the specific transitive versions of each thing
    we're going to use.)  That means we have a 'ComponentId' for
    this component.  This module also contains functions for
    creating a 'ConfiguredComponent' from a source 'Component'.

    A linked component is one which we have done mix-in linking
    for, so we know its 'IndefUnitId' and its 'IndefUnitId'
    This module calls out to mix-in linking to actually do linking.
    The workhorse, in a sense!

    This module implements the instantiation process, where we
    zip through all of the fully instantiated components, and
    recursively instantiate their dependencies, so that we
    get a separate linked component per thing we need to
    compile, and also finishes off any top-level indefinite
    components.  This gives us the final 'UnitId' for our

    This functionality is reimplemented in a different way in
    cabal-install; the assumptions are slightly different (in
    particular, in the library we can't assume we have access to all
    packages to build them; but in cabal-install we can assume it) so I
    didn't try to abstract over both implementations.

    This is a "interoperability" data type which identifies
    precisely the information from a 'LinkedComponent' that
    can be derived from an 'InstalledPackageInfo'.
parent be1a184c
......@@ -316,6 +316,15 @@ library
......@@ -418,12 +427,20 @@ library
-- | See <>
module Distribution.Backpack.ComponentsGraph (
) 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 the set of package names which
-- are considered internal (the current package name and any internal
-- libraries are considered internal), 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 ]
-- 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 ]
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 <>
-- WARNING: The contents of this module are HIGHLY experimental.
-- We may refactor it under you.
module Distribution.Backpack.Configure (
) 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
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
:: 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)
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
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_indef_uid pkg, pc_shape pkg))
| pkg <- prePkgDeps]
uid_lookup uid
| Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid
= FullUnitId (Installed.installedComponentId pkg)
(Map.fromList (Installed.instantiatedWith pkg))
| otherwise = error ("uid_lookup: " ++ display 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 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
:: Compiler
-> InstalledPackageIndex -- FULL set
-> PackageDescription
-> [PreExistingComponent] -- external package deps
-> [ReadyComponent]
-> LogProgress ([ComponentLocalBuildInfo],
InstalledPackageIndex) -- only relevant packages
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:
-- * We'll use it to do a consistency check so we're not depending
-- on multiple versions of the same package (TODO: someday relax
-- this for private dependencies.) See right below.
-- * We'll pass it on in the LocalBuildInfo, where preprocessors
-- and other things will incorrectly use it to determine what
-- the include paths and everything should be.
packageDependsIndex = PackageIndex.fromList (lefts local_graph)
fullIndex = Graph.fromList local_graph
case Graph.broken fullIndex of
[] -> return ()
broken ->
-- TODO: ppr this
failProgress . text $
"The following packages are broken because other"
++ " packages they depend on are missing. These broken "
++ "packages must be rebuilt before they can be used.\n"
-- TODO: Undupe.
++ unlines [ "installed package "
++ display (packageId pkg)
++ " is broken due to missing package "
++ intercalate ", " (map display deps)
| (Left pkg, deps) <- broken ]
++ unlines [ "planned package "
++ display (packageId pkg)
++ " is broken due to missing package "
++ intercalate ", " (map display deps)
| (Right pkg, deps) <- broken ]
-- In this section, we'd like to look at the 'packageDependsIndex'
-- and see if we've picked multiple versions of the same
-- installed package (this is bad, because it means you might
-- get an error could not match foo-0.1:Type with foo-0.2:Type).
-- What is pseudoTopPkg for? I have no idea. It was used
-- in the very original commit which introduced checking for
-- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012,
-- and then moved out of PackageIndex and put here later.
-- TODO: Try this code without it...
-- TODO: Move this into a helper function
-- TODO: This is probably wrong for Backpack
let pseudoTopPkg :: InstalledPackageInfo
pseudoTopPkg = emptyInstalledPackageInfo {
Installed.installedUnitId =
mkLegacyUnitId (packageId pkg_descr),
Installed.sourcePackageId = packageId pkg_descr,
Installed.depends =
map pc_uid externalPkgDeps
case PackageIndex.dependencyInconsistencies
. PackageIndex.insert pseudoTopPkg
$ packageDependsIndex of
[] -> return ()
inconsistencies ->
warnProgress . text $
"This package indirectly depends on multiple versions of the same "
++ "package. This is highly likely to cause a compile failure.\n"
++ unlines [ "package " ++ display pkg ++ " requires "
++ display (PackageIdentifier name ver)
| (name, uses) <- inconsistencies
, (pkg, ver) <- uses ]
let clbis = mkLinkedComponentsLocalBuildInfo comp graph
-- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)
return (clbis, packageDependsIndex)
-- Build ComponentLocalBuildInfo for each component we are going
-- to build.
-- This conversion is lossy; we lose some invariants from ReadyComponent
:: Compiler
-> [ReadyComponent]
-> [ComponentLocalBuildInfo]
mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
internalUnits = Set.fromList (map rc_uid rcs)
isInternal x = Set.member x internalUnits
go rc =
case rc_component rc of
CLib _ ->
let convModuleExport (modname', (Module uid modname))
| this_uid == uid
, modname' == modname
= Installed.ExposedModule modname' Nothing
| otherwise
= Installed.ExposedModule modname'
(Just (IndefModule (IndefUnitId uid) modname))
convIndefModuleExport (modname', modu@(IndefModule uid modname))
-- TODO: This isn't a good enough test if we have mutual
-- recursion (but maybe we'll get saved by the module name
-- check regardless.)
| indefUnitIdComponentId uid == this_cid
, modname' == modname
= Installed.ExposedModule modname' Nothing
| otherwise
= Installed.ExposedModule modname' (Just modu)
convIndefModuleExport (_, IndefModuleVar _)
= error "convIndefModuleExport: top-level modvar"
exports =
-- Loses invariants
case rc_i rc of
Left indefc -> map convIndefModuleExport
$ Map.toList (indefc_provides indefc)
Right instc -> map convModuleExport
$ Map.toList (instc_provides instc)
insts =
case rc_i rc of
Left indefc -> [ (m, IndefModuleVar m) | m <- indefc_requires indefc ]
Right instc -> [ (m, IndefModule (IndefUnitId uid') m')
| (m, Module uid' m') <- instc_insts instc ]
in LibComponentLocalBuildInfo {
componentPackageDeps = cpds,
componentUnitId = this_uid,
componentInstantiatedWith = insts,
componentIsIndefinite_ = is_indefinite,
componentLocalName = cname,
componentInternalDeps = internal_deps,
componentExeDeps = rc_internal_build_tools rc,
componentIncludes = includes,
componentExposedModules = exports,
componentIsPublic = rc_public rc,
componentCompatPackageKey = rc_compat_key rc comp,
componentCompatPackageName = rc_compat_name rc
CExe _ ->
ExeComponentLocalBuildInfo {
componentUnitId = this_uid,
componentLocalName = cname,
componentPackageDeps = cpds,
componentExeDeps = rc_internal_build_tools rc,
componentInternalDeps = internal_deps,
componentIncludes = includes
CTest _ ->
TestComponentLocalBuildInfo {
componentUnitId = this_uid,
componentLocalName = cname,
componentPackageDeps = cpds,
componentExeDeps = rc_internal_build_tools rc,
componentInternalDeps = internal_deps,
componentIncludes = includes
CBench _ ->
BenchComponentLocalBuildInfo {
componentUnitId = this_uid,
componentLocalName = cname,
componentPackageDeps = cpds,
componentExeDeps = rc_internal_build_tools rc,
componentInternalDeps = internal_deps,
componentIncludes = includes
this_uid = rc_uid rc
this_cid = unitIdComponentId this_uid
cname = componentName (rc_component rc)
cpds = rc_depends rc
is_indefinite =
case rc_i rc of
Left _ -> True
Right _ -> False
includes =
case rc_i rc of
Left indefc ->
indefc_includes indefc
Right instc ->
map (\(x,y) -> (IndefUnitId x,y)) (instc_includes instc)
internal_deps =
filter isInternal (nodeNeighbors rc)
++ rc_internal_build_tools rc
{-# LANGUAGE PatternGuards #-}
-- | See <>
module Distribution.Backpack.ConfiguredComponent (
-- TODO: Should go somewhere else
) where
import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
import Distribution.Backpack.Id
import Distribution.Types.IncludeRenaming
import Distribution.Package
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.Simple.Setup as Setup
import Distribution.Simple.LocalBuildInfo
import Distribution.Version
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Traversable
( mapAccumL )
import Distribution.Text
import Text.PrettyPrint
-- | A configured component, we know exactly what its 'ComponentId' is,
-- and the 'ComponentId's of the things it depends on.
data ConfiguredComponent
= ConfiguredComponent {
cc_cid :: ComponentId,
-- The package this component came from.
cc_pkgid :: PackageId,
cc_component :: Component,
cc_public :: Bool,
-- ^ Is this the public library component of the package?
-- (THIS is what the hole instantiation applies to.)
-- Note that in one-component configure mode, this is
-- always True, because any component is the "public" one.)
cc_internal_build_tools :: [ComponentId],
-- Not resolved yet; component configuration only looks at ComponentIds.
cc_includes :: [(ComponentId, PackageId, IncludeRenaming)]
cc_name :: ConfiguredComponent -> ComponentName
cc_name = componentName . cc_component
dispConfiguredComponent :: ConfiguredComponent -> Doc
dispConfiguredComponent cc =
hang (text "component" <+> disp (cc_cid cc)) 4
(vcat [ hsep $ [ text "include", disp cid, disp incl_rn ]
| (cid, _, incl_rn) <- cc_includes cc
-- | Construct a 'ConfiguredComponent', given that the 'ComponentId'
-- and library/executable dependencies are known. The primary
-- work this does is handling implicit @backpack-include@ fields.
:: PackageId
-> ComponentId
-> [(PackageName, (ComponentId, PackageId))]
-> [ComponentId]
-> Component
-> ConfiguredComponent
mkConfiguredComponent this_pid this_cid lib_deps exe_deps component =
ConfiguredComponent {
cc_cid = this_cid,
cc_pkgid = this_pid,
cc_component = component,
cc_public = is_public,
cc_internal_build_tools = exe_deps,
cc_includes = explicit_includes ++ implicit_includes
bi = componentBuildInfo component
deps = map snd lib_deps
deps_map = Map.fromList lib_deps
-- Resolve each @backpack-include@ into the actual dependency
-- from @lib_deps@.
= [ (cid, pid { pkgName = name }, rns)
| (name, rns) <- backpackIncludes bi
, Just (cid, pid) <- [Map.lookup name deps_map] ]
-- Any @build-depends@ which is not explicitly mentioned in
-- @backpack-include@ is converted into an "implicit" include.
used_explicitly = Set.fromList (map (\(cid,_,_) -> cid) explicit_includes)
= map (\(cid, pid) -> (cid, pid, defaultIncludeRenaming))
$ filter (flip Set.notMember used_explicitly . fst) deps
is_public = componentName component == CLibName
type ConfiguredComponentMap =
(Map PackageName (ComponentId, PackageId), -- libraries
Map String ComponentId) -- executables
-- Executable map must be different because an executable can
-- have the same name as a library. Ew.
-- | Given some ambient environment of package names that
-- are "in scope", looks at the 'BuildInfo' to decide
-- what the packages actually resolve to, and then builds
-- a 'ConfiguredComponent'.
:: PackageDescription
-> ComponentId
-> Map PackageName (ComponentId, PackageId) -- external
-> ConfiguredComponentMap
-> Component
-> ConfiguredComponent
toConfiguredComponent pkg_descr this_cid
external_lib_map (lib_map, exe_map) component =
(package pkg_descr) this_cid
lib_deps exe_deps component
bi = componentBuildInfo component
find_it :: PackageName -> VersionRange -> (ComponentId, PackageId)
find_it name reqVer =
fromMaybe (error ("toConfiguredComponent: " ++ display name)) $
lookup_name lib_map <|>
lookup_name external_lib_map
lookup_name m =
case Map.lookup name m of
Just (cid, pkgid)
| packageVersion pkgid `withinRange` reqVer
-> Just (cid, pkgid)
_ -> Nothing
| newPackageDepsBehaviour pkg_descr
= [ (name, find_it name reqVer)
| Dependency name reqVer <- targetBuildDepends bi ]
| otherwise