Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
8fa4d2ea
Commit
8fa4d2ea
authored
Oct 06, 2016
by
Edward Z. Yang
Committed by
GitHub
Oct 06, 2016
Browse files
Merge pull request #3672 from ezyang/backpack
Backpack
parents
f8095ac4
cf7e3313
Changes
163
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
8fa4d2ea
# trivial gitignore file
.cabal-sandbox/
cabal.sandbox.config
cabal.project.local
cabal-dev/
.hpc/
*.hi
...
...
Cabal/Cabal.cabal
View file @
8fa4d2ea
...
...
@@ -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
0 → 100644
View file @
8fa4d2ea
{-# 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
0 → 100644
View file @
8fa4d2ea
-- | 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
0 → 100644
View file @
8fa4d2ea
{-# 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