{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
module Distribution.Backpack.Configure
( configureComponentLocalBuildInfos
) where
import Distribution.Compat.Prelude hiding ((<>))
import Prelude ()
import Distribution.Backpack
import Distribution.Backpack.ComponentsGraph
import Distribution.Backpack.ConfiguredComponent
import Distribution.Backpack.FullUnitId
import Distribution.Backpack.Id
import Distribution.Backpack.LinkedComponent
import Distribution.Backpack.PreExistingComponent
import Distribution.Backpack.ReadyComponent
import Distribution.Backpack.ModuleShape
import Distribution.Compat.Graph (Graph, IsNode (..))
import qualified Distribution.Compat.Graph as Graph
import Distribution.InstalledPackageInfo
( InstalledPackageInfo
, emptyInstalledPackageInfo
)
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Types.AnnotatedId
import Distribution.Types.ComponentInclude
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.MungedPackageName
import Distribution.Utils.LogProgress
import Distribution.Verbosity
import Data.Either
( lefts
)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Pretty
import Text.PrettyPrint
configureComponentLocalBuildInfos
:: Verbosity
-> Bool
-> ComponentRequestedSpec
-> Bool
-> Flag String
-> Flag ComponentId
-> PackageDescription
-> ([PreExistingComponent], [PromisedComponent])
-> FlagAssignment
-> [(ModuleName, Module)]
-> InstalledPackageIndex
-> Compiler
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
configureComponentLocalBuildInfos :: Verbosity
-> Bool
-> ComponentRequestedSpec
-> Bool
-> Flag [Char]
-> Flag ComponentId
-> PackageDescription
-> ([PreExistingComponent], [PromisedComponent])
-> FlagAssignment
-> [(ModuleName, Module)]
-> InstalledPackageIndex
-> Compiler
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
configureComponentLocalBuildInfos
Verbosity
verbosity
Bool
use_external_internal_deps
ComponentRequestedSpec
enabled
Bool
deterministic
Flag [Char]
ipid_flag
Flag ComponentId
cid_flag
PackageDescription
pkg_descr
([PreExistingComponent]
prePkgDeps, [PromisedComponent]
promisedPkgDeps)
FlagAssignment
flagAssignment
[(ModuleName, Module)]
instantiate_with
InstalledPackageIndex
installedPackageSet
Compiler
comp = do
ComponentsWithDeps
graph0 <- case ComponentRequestedSpec
-> PackageDescription -> Either [ComponentName] ComponentsGraph
mkComponentsGraph ComponentRequestedSpec
enabled PackageDescription
pkg_descr of
Left [ComponentName]
ccycle -> Doc -> LogProgress ComponentsWithDeps
forall a. Doc -> LogProgress a
dieProgress (PackageIdentifier -> [ComponentName] -> Doc
componentCycleMsg (PackageDescription -> PackageIdentifier
package PackageDescription
pkg_descr) [ComponentName]
ccycle)
Right ComponentsGraph
g -> ComponentsWithDeps -> LogProgress ComponentsWithDeps
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentsGraph -> ComponentsWithDeps
componentsGraphToList ComponentsGraph
g)
Doc -> LogProgress ()
infoProgress (Doc -> LogProgress ()) -> Doc -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
Doc -> Int -> Doc -> Doc
hang
([Char] -> Doc
text [Char]
"Source component graph:")
Int
4
(ComponentsWithDeps -> Doc
dispComponentsWithDeps ComponentsWithDeps
graph0)
let conf_pkg_map :: Map PackageName (Map ComponentName (AnnotatedId ComponentId))
conf_pkg_map =
(Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId))
-> [(PackageName, Map ComponentName (AnnotatedId ComponentId))]
-> Map PackageName (Map ComponentName (AnnotatedId ComponentId))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
[ ( PreExistingComponent -> PackageName
pc_pkgname PreExistingComponent
pkg
, ComponentName
-> AnnotatedId ComponentId
-> Map ComponentName (AnnotatedId ComponentId)
forall k a. k -> a -> Map k a
Map.singleton
(PreExistingComponent -> ComponentName
pc_compname PreExistingComponent
pkg)
( AnnotatedId
{ ann_id :: ComponentId
ann_id = PreExistingComponent -> ComponentId
pc_cid PreExistingComponent
pkg
, ann_pid :: PackageIdentifier
ann_pid = PreExistingComponent -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PreExistingComponent
pkg
, ann_cname :: ComponentName
ann_cname = PreExistingComponent -> ComponentName
pc_compname PreExistingComponent
pkg
}
)
)
| PreExistingComponent
pkg <- [PreExistingComponent]
prePkgDeps
]
Map PackageName (Map ComponentName (AnnotatedId ComponentId))
-> Map PackageName (Map ComponentName (AnnotatedId ComponentId))
-> Map PackageName (Map ComponentName (AnnotatedId ComponentId))
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId))
-> [(PackageName, Map ComponentName (AnnotatedId ComponentId))]
-> Map PackageName (Map ComponentName (AnnotatedId ComponentId))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId)
-> Map ComponentName (AnnotatedId ComponentId)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
[ (PackageName
pkg, ComponentName
-> AnnotatedId ComponentId
-> Map ComponentName (AnnotatedId ComponentId)
forall k a. k -> a -> Map k a
Map.singleton (AnnotatedId ComponentId -> ComponentName
forall id. AnnotatedId id -> ComponentName
ann_cname AnnotatedId ComponentId
aid) AnnotatedId ComponentId
aid)
| PromisedComponent PackageName
pkg AnnotatedId ComponentId
aid <- [PromisedComponent]
promisedPkgDeps
]
[ConfiguredComponent]
graph1 <-
Bool
-> FlagAssignment
-> Bool
-> Flag [Char]
-> Flag ComponentId
-> PackageDescription
-> Map PackageName (Map ComponentName (AnnotatedId ComponentId))
-> [Component]
-> LogProgress [ConfiguredComponent]
toConfiguredComponents
Bool
use_external_internal_deps
FlagAssignment
flagAssignment
Bool
deterministic
Flag [Char]
ipid_flag
Flag ComponentId
cid_flag
PackageDescription
pkg_descr
Map PackageName (Map ComponentName (AnnotatedId ComponentId))
conf_pkg_map
(((Component, [ComponentName]) -> Component)
-> ComponentsWithDeps -> [Component]
forall a b. (a -> b) -> [a] -> [b]
map (Component, [ComponentName]) -> Component
forall a b. (a, b) -> a
fst ComponentsWithDeps
graph0)
Doc -> LogProgress ()
infoProgress (Doc -> LogProgress ()) -> Doc -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
Doc -> Int -> Doc -> Doc
hang
([Char] -> Doc
text [Char]
"Configured component graph:")
Int
4
([Doc] -> Doc
vcat ((ConfiguredComponent -> Doc) -> [ConfiguredComponent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ConfiguredComponent -> Doc
dispConfiguredComponent [ConfiguredComponent]
graph1))
let shape_pkg_map :: Map ComponentId (OpenUnitId, ModuleShape)
shape_pkg_map =
[(ComponentId, (OpenUnitId, ModuleShape))]
-> Map ComponentId (OpenUnitId, ModuleShape)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (PreExistingComponent -> ComponentId
pc_cid PreExistingComponent
pkg, (PreExistingComponent -> OpenUnitId
pc_open_uid PreExistingComponent
pkg, PreExistingComponent -> ModuleShape
pc_shape PreExistingComponent
pkg))
| PreExistingComponent
pkg <- [PreExistingComponent]
prePkgDeps
]
Map ComponentId (OpenUnitId, ModuleShape)
-> Map ComponentId (OpenUnitId, ModuleShape)
-> Map ComponentId (OpenUnitId, ModuleShape)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` [(ComponentId, (OpenUnitId, ModuleShape))]
-> Map ComponentId (OpenUnitId, ModuleShape)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ ( AnnotatedId ComponentId -> ComponentId
forall id. AnnotatedId id -> id
ann_id AnnotatedId ComponentId
aid
,
( DefUnitId -> OpenUnitId
DefiniteUnitId
( UnitId -> DefUnitId
unsafeMkDefUnitId
([Char] -> UnitId
mkUnitId (ComponentId -> [Char]
unComponentId (AnnotatedId ComponentId -> ComponentId
forall id. AnnotatedId id -> id
ann_id AnnotatedId ComponentId
aid)))
)
, ModuleShape
emptyModuleShape
)
)
| PromisedComponent PackageName
_ AnnotatedId ComponentId
aid <- [PromisedComponent]
promisedPkgDeps
]
uid_lookup :: DefUnitId -> FullUnitId
uid_lookup DefUnitId
def_uid
| Just InstalledPackageInfo
pkg <- InstalledPackageIndex -> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
PackageIndex.lookupUnitId InstalledPackageIndex
installedPackageSet UnitId
uid =
ComponentId -> OpenModuleSubst -> FullUnitId
FullUnitId
(InstalledPackageInfo -> ComponentId
Installed.installedComponentId InstalledPackageInfo
pkg)
([(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (InstalledPackageInfo -> [(ModuleName, OpenModule)]
Installed.instantiatedWith InstalledPackageInfo
pkg))
| Bool
otherwise = [Char] -> FullUnitId
forall a. HasCallStack => [Char] -> a
error ([Char]
"uid_lookup: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow UnitId
uid)
where
uid :: UnitId
uid = DefUnitId -> UnitId
unDefUnitId DefUnitId
def_uid
[LinkedComponent]
graph2 <-
Verbosity
-> Bool
-> (DefUnitId -> FullUnitId)
-> PackageIdentifier
-> Map ComponentId (OpenUnitId, ModuleShape)
-> [ConfiguredComponent]
-> LogProgress [LinkedComponent]
toLinkedComponents
Verbosity
verbosity
(Bool -> Bool
not ([PromisedComponent] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PromisedComponent]
promisedPkgDeps))
DefUnitId -> FullUnitId
uid_lookup
(PackageDescription -> PackageIdentifier
package PackageDescription
pkg_descr)
Map ComponentId (OpenUnitId, ModuleShape)
shape_pkg_map
[ConfiguredComponent]
graph1
Doc -> LogProgress ()
infoProgress (Doc -> LogProgress ()) -> Doc -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
Doc -> Int -> Doc -> Doc
hang
([Char] -> Doc
text [Char]
"Linked component graph:")
Int
4
([Doc] -> Doc
vcat ((LinkedComponent -> Doc) -> [LinkedComponent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map LinkedComponent -> Doc
dispLinkedComponent [LinkedComponent]
graph2))
let pid_map :: Map UnitId MungedPackageId
pid_map =
[(UnitId, MungedPackageId)] -> Map UnitId MungedPackageId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UnitId, MungedPackageId)] -> Map UnitId MungedPackageId)
-> [(UnitId, MungedPackageId)] -> Map UnitId MungedPackageId
forall a b. (a -> b) -> a -> b
$
[ (PreExistingComponent -> UnitId
pc_uid PreExistingComponent
pkg, PreExistingComponent -> MungedPackageId
pc_munged_id PreExistingComponent
pkg)
| PreExistingComponent
pkg <- [PreExistingComponent]
prePkgDeps
]
[(UnitId, MungedPackageId)]
-> [(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)]
forall a. [a] -> [a] -> [a]
++ [ (InstalledPackageInfo -> UnitId
Installed.installedUnitId InstalledPackageInfo
pkg, InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId InstalledPackageInfo
pkg)
| (ModuleName
_, Module DefUnitId
uid ModuleName
_) <- [(ModuleName, Module)]
instantiate_with
, Just InstalledPackageInfo
pkg <-
[ InstalledPackageIndex -> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
PackageIndex.lookupUnitId
InstalledPackageIndex
installedPackageSet
(DefUnitId -> UnitId
unDefUnitId DefUnitId
uid)
]
]
subst :: Map ModuleName Module
subst = [(ModuleName, Module)] -> Map ModuleName Module
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ModuleName, Module)]
instantiate_with
graph3 :: [ReadyComponent]
graph3 = Map UnitId MungedPackageId
-> Map ModuleName Module -> [LinkedComponent] -> [ReadyComponent]
toReadyComponents Map UnitId MungedPackageId
pid_map Map ModuleName Module
subst [LinkedComponent]
graph2
graph4 :: [ReadyComponent]
graph4 = Graph ReadyComponent -> [ReadyComponent]
forall a. Graph a -> [a]
Graph.revTopSort ([ReadyComponent] -> Graph ReadyComponent
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList [ReadyComponent]
graph3)
Doc -> LogProgress ()
infoProgress (Doc -> LogProgress ()) -> Doc -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
Doc -> Int -> Doc -> Doc
hang
([Char] -> Doc
text [Char]
"Ready component graph:")
Int
4
([Doc] -> Doc
vcat ((ReadyComponent -> Doc) -> [ReadyComponent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ReadyComponent -> Doc
dispReadyComponent [ReadyComponent]
graph4))
Compiler
-> InstalledPackageIndex
-> [PromisedComponent]
-> PackageDescription
-> [PreExistingComponent]
-> [ReadyComponent]
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
toComponentLocalBuildInfos Compiler
comp InstalledPackageIndex
installedPackageSet [PromisedComponent]
promisedPkgDeps PackageDescription
pkg_descr [PreExistingComponent]
prePkgDeps [ReadyComponent]
graph4
toComponentLocalBuildInfos
:: Compiler
-> InstalledPackageIndex
-> [PromisedComponent]
-> PackageDescription
-> [PreExistingComponent]
-> [ReadyComponent]
-> LogProgress
( [ComponentLocalBuildInfo]
, InstalledPackageIndex
)
toComponentLocalBuildInfos :: Compiler
-> InstalledPackageIndex
-> [PromisedComponent]
-> PackageDescription
-> [PreExistingComponent]
-> [ReadyComponent]
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
toComponentLocalBuildInfos
Compiler
comp
InstalledPackageIndex
installedPackageSet
[PromisedComponent]
promisedPkgDeps
PackageDescription
pkg_descr
[PreExistingComponent]
externalPkgDeps
[ReadyComponent]
graph = do
let
external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
external_graph =
[Either InstalledPackageInfo ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList
([Either InstalledPackageInfo ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent))
-> ([InstalledPackageInfo]
-> [Either InstalledPackageInfo ReadyComponent])
-> [InstalledPackageInfo]
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo
-> Either InstalledPackageInfo ReadyComponent)
-> [InstalledPackageInfo]
-> [Either InstalledPackageInfo ReadyComponent]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> Either InstalledPackageInfo ReadyComponent
forall a b. a -> Either a b
Left
([InstalledPackageInfo]
-> Graph (Either InstalledPackageInfo ReadyComponent))
-> [InstalledPackageInfo]
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex -> [InstalledPackageInfo]
forall a. PackageIndex a -> [a]
PackageIndex.allPackages InstalledPackageIndex
installedPackageSet
internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
internal_graph =
[Either InstalledPackageInfo ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList
([Either InstalledPackageInfo ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent))
-> ([ReadyComponent]
-> [Either InstalledPackageInfo ReadyComponent])
-> [ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReadyComponent -> Either InstalledPackageInfo ReadyComponent)
-> [ReadyComponent] -> [Either InstalledPackageInfo ReadyComponent]
forall a b. (a -> b) -> [a] -> [b]
map ReadyComponent -> Either InstalledPackageInfo ReadyComponent
forall a b. b -> Either a b
Right
([ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent))
-> [ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall a b. (a -> b) -> a -> b
$ [ReadyComponent]
graph
combined_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
combined_graph = Graph (Either InstalledPackageInfo ReadyComponent)
-> Graph (Either InstalledPackageInfo ReadyComponent)
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall a. IsNode a => Graph a -> Graph a -> Graph a
Graph.unionRight Graph (Either InstalledPackageInfo ReadyComponent)
external_graph Graph (Either InstalledPackageInfo ReadyComponent)
internal_graph
local_graph :: [Either InstalledPackageInfo ReadyComponent]
local_graph =
[Either InstalledPackageInfo ReadyComponent]
-> Maybe [Either InstalledPackageInfo ReadyComponent]
-> [Either InstalledPackageInfo ReadyComponent]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Either InstalledPackageInfo ReadyComponent]
forall a. HasCallStack => [Char] -> a
error [Char]
"toComponentLocalBuildInfos: closure returned Nothing") (Maybe [Either InstalledPackageInfo ReadyComponent]
-> [Either InstalledPackageInfo ReadyComponent])
-> Maybe [Either InstalledPackageInfo ReadyComponent]
-> [Either InstalledPackageInfo ReadyComponent]
forall a b. (a -> b) -> a -> b
$
Graph (Either InstalledPackageInfo ReadyComponent)
-> [Key (Either InstalledPackageInfo ReadyComponent)]
-> Maybe [Either InstalledPackageInfo ReadyComponent]
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.closure Graph (Either InstalledPackageInfo ReadyComponent)
combined_graph ((ReadyComponent -> UnitId) -> [ReadyComponent] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map ReadyComponent -> Key ReadyComponent
ReadyComponent -> UnitId
forall a. IsNode a => a -> Key a
nodeKey [ReadyComponent]
graph)
packageDependsIndex :: InstalledPackageIndex
packageDependsIndex = [InstalledPackageInfo] -> InstalledPackageIndex
PackageIndex.fromList ([Either InstalledPackageInfo ReadyComponent]
-> [InstalledPackageInfo]
forall a b. [Either a b] -> [a]
lefts [Either InstalledPackageInfo ReadyComponent]
local_graph)
fullIndex :: Graph (Either InstalledPackageInfo ReadyComponent)
fullIndex = [Either InstalledPackageInfo ReadyComponent]
-> Graph (Either InstalledPackageInfo ReadyComponent)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList [Either InstalledPackageInfo ReadyComponent]
local_graph
case Graph (Either InstalledPackageInfo ReadyComponent)
-> [(Either InstalledPackageInfo ReadyComponent,
[Key (Either InstalledPackageInfo ReadyComponent)])]
forall a. Graph a -> [(a, [Key a])]
Graph.broken Graph (Either InstalledPackageInfo ReadyComponent)
fullIndex of
[] -> () -> LogProgress ()
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(Either InstalledPackageInfo ReadyComponent,
[Key (Either InstalledPackageInfo ReadyComponent)])]
broken
| Bool -> Bool
not ([PromisedComponent] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PromisedComponent]
promisedPkgDeps) -> () -> LogProgress ()
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise ->
Doc -> LogProgress ()
forall a. Doc -> LogProgress a
dieProgress (Doc -> LogProgress ())
-> ([Char] -> Doc) -> [Char] -> LogProgress ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Doc
text ([Char] -> LogProgress ()) -> [Char] -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
[Char]
"The following packages are broken because other"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" packages they depend on are missing. These broken "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"packages must be rebuilt before they can be used.\n"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines
[ [Char]
"installed package "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
pkg)
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is broken due to missing package "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((UnitId -> [Char]) -> [UnitId] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [UnitId]
deps)
| (Left InstalledPackageInfo
pkg, [UnitId]
deps) <- [(Either InstalledPackageInfo ReadyComponent,
[Key (Either InstalledPackageInfo ReadyComponent)])]
[(Either InstalledPackageInfo ReadyComponent, [UnitId])]
broken
]
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines
[ [Char]
"planned package "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (ReadyComponent -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ReadyComponent
pkg)
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is broken due to missing package "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((UnitId -> [Char]) -> [UnitId] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [UnitId]
deps)
| (Right ReadyComponent
pkg, [UnitId]
deps) <- [(Either InstalledPackageInfo ReadyComponent,
[Key (Either InstalledPackageInfo ReadyComponent)])]
[(Either InstalledPackageInfo ReadyComponent, [UnitId])]
broken
]
let pseudoTopPkg :: InstalledPackageInfo
pseudoTopPkg :: InstalledPackageInfo
pseudoTopPkg =
InstalledPackageInfo
emptyInstalledPackageInfo
{ Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr)
, Installed.sourcePackageId = packageId pkg_descr
, Installed.depends = map pc_uid externalPkgDeps
}
case InstalledPackageIndex
-> [(DepUniqueKey, [(UnitId, [InstalledPackageInfo])])]
PackageIndex.dependencyInconsistencies
(InstalledPackageIndex
-> [(DepUniqueKey, [(UnitId, [InstalledPackageInfo])])])
-> (InstalledPackageIndex -> InstalledPackageIndex)
-> InstalledPackageIndex
-> [(DepUniqueKey, [(UnitId, [InstalledPackageInfo])])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo
-> InstalledPackageIndex -> InstalledPackageIndex
PackageIndex.insert InstalledPackageInfo
pseudoTopPkg
(InstalledPackageIndex
-> [(DepUniqueKey, [(UnitId, [InstalledPackageInfo])])])
-> InstalledPackageIndex
-> [(DepUniqueKey, [(UnitId, [InstalledPackageInfo])])]
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
packageDependsIndex of
[] -> () -> LogProgress ()
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(DepUniqueKey, [(UnitId, [InstalledPackageInfo])])]
inconsistencies ->
Doc -> LogProgress ()
warnProgress (Doc -> LogProgress ()) -> Doc -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
Doc -> Int -> Doc -> Doc
hang
( [Char] -> Doc
text [Char]
"This package indirectly depends on multiple versions of the same"
Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"package. This is very likely to cause a compile failure."
)
Int
2
( [Doc] -> Doc
vcat
[ [Char] -> Doc
text [Char]
"package"
Doc -> Doc -> Doc
<+> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty (InstalledPackageInfo -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName InstalledPackageInfo
user)
Doc -> Doc -> Doc
<+> Doc -> Doc
parens (UnitId -> Doc
forall a. Pretty a => a -> Doc
pretty (InstalledPackageInfo -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId InstalledPackageInfo
user))
Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"requires"
Doc -> Doc -> Doc
<+> UnitId -> Doc
forall a. Pretty a => a -> Doc
pretty UnitId
inst
| (DepUniqueKey
_dep_key, [(UnitId, [InstalledPackageInfo])]
insts) <- [(DepUniqueKey, [(UnitId, [InstalledPackageInfo])])]
inconsistencies
, (UnitId
inst, [InstalledPackageInfo]
users) <- [(UnitId, [InstalledPackageInfo])]
insts
, InstalledPackageInfo
user <- [InstalledPackageInfo]
users
]
)
let clbis :: [ComponentLocalBuildInfo]
clbis = Compiler -> [ReadyComponent] -> [ComponentLocalBuildInfo]
mkLinkedComponentsLocalBuildInfo Compiler
comp [ReadyComponent]
graph
([ComponentLocalBuildInfo], InstalledPackageIndex)
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ComponentLocalBuildInfo]
clbis, InstalledPackageIndex
packageDependsIndex)
mkLinkedComponentsLocalBuildInfo
:: Compiler
-> [ReadyComponent]
-> [ComponentLocalBuildInfo]
mkLinkedComponentsLocalBuildInfo :: Compiler -> [ReadyComponent] -> [ComponentLocalBuildInfo]
mkLinkedComponentsLocalBuildInfo Compiler
comp [ReadyComponent]
rcs = (ReadyComponent -> ComponentLocalBuildInfo)
-> [ReadyComponent] -> [ComponentLocalBuildInfo]
forall a b. (a -> b) -> [a] -> [b]
map ReadyComponent -> ComponentLocalBuildInfo
go [ReadyComponent]
rcs
where
internalUnits :: Set UnitId
internalUnits = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ((ReadyComponent -> UnitId) -> [ReadyComponent] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map ReadyComponent -> UnitId
rc_uid [ReadyComponent]
rcs)
isInternal :: UnitId -> Bool
isInternal UnitId
x = UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member UnitId
x Set UnitId
internalUnits
go :: ReadyComponent -> ComponentLocalBuildInfo
go ReadyComponent
rc =
case ReadyComponent -> Component
rc_component ReadyComponent
rc of
CLib Library
lib ->
let convModuleExport :: (ModuleName, Module) -> ExposedModule
convModuleExport (ModuleName
modname', (Module DefUnitId
uid ModuleName
modname))
| UnitId
this_uid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DefUnitId -> UnitId
unDefUnitId DefUnitId
uid
, ModuleName
modname' ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
modname =
ModuleName -> Maybe OpenModule -> ExposedModule
Installed.ExposedModule ModuleName
modname' Maybe OpenModule
forall a. Maybe a
Nothing
| Bool
otherwise =
ModuleName -> Maybe OpenModule -> ExposedModule
Installed.ExposedModule
ModuleName
modname'
(OpenModule -> Maybe OpenModule
forall a. a -> Maybe a
Just (OpenUnitId -> ModuleName -> OpenModule
OpenModule (DefUnitId -> OpenUnitId
DefiniteUnitId DefUnitId
uid) ModuleName
modname))
convOpenModuleExport :: (ModuleName, OpenModule) -> ExposedModule
convOpenModuleExport (ModuleName
modname', modu :: OpenModule
modu@(OpenModule OpenUnitId
uid ModuleName
modname))
| OpenUnitId
uid OpenUnitId -> OpenUnitId -> Bool
forall a. Eq a => a -> a -> Bool
== OpenUnitId
this_open_uid
, ModuleName
modname' ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
modname =
ModuleName -> Maybe OpenModule -> ExposedModule
Installed.ExposedModule ModuleName
modname' Maybe OpenModule
forall a. Maybe a
Nothing
| Bool
otherwise =
ModuleName -> Maybe OpenModule -> ExposedModule
Installed.ExposedModule ModuleName
modname' (OpenModule -> Maybe OpenModule
forall a. a -> Maybe a
Just OpenModule
modu)
convOpenModuleExport (ModuleName
_, OpenModuleVar ModuleName
_) =
[Char] -> ExposedModule
forall a. HasCallStack => [Char] -> a
error [Char]
"convOpenModuleExport: top-level modvar"
exports :: [ExposedModule]
exports =
case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
Left IndefiniteComponent
indefc ->
((ModuleName, OpenModule) -> ExposedModule)
-> [(ModuleName, OpenModule)] -> [ExposedModule]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, OpenModule) -> ExposedModule
convOpenModuleExport ([(ModuleName, OpenModule)] -> [ExposedModule])
-> [(ModuleName, OpenModule)] -> [ExposedModule]
forall a b. (a -> b) -> a -> b
$
OpenModuleSubst -> [(ModuleName, OpenModule)]
forall k a. Map k a -> [(k, a)]
Map.toList (IndefiniteComponent -> OpenModuleSubst
indefc_provides IndefiniteComponent
indefc)
Right InstantiatedComponent
instc ->
((ModuleName, Module) -> ExposedModule)
-> [(ModuleName, Module)] -> [ExposedModule]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Module) -> ExposedModule
convModuleExport ([(ModuleName, Module)] -> [ExposedModule])
-> [(ModuleName, Module)] -> [ExposedModule]
forall a b. (a -> b) -> a -> b
$
Map ModuleName Module -> [(ModuleName, Module)]
forall k a. Map k a -> [(k, a)]
Map.toList (InstantiatedComponent -> Map ModuleName Module
instc_provides InstantiatedComponent
instc)
insts :: [(ModuleName, OpenModule)]
insts =
case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
Left IndefiniteComponent
indefc -> [(ModuleName
m, ModuleName -> OpenModule
OpenModuleVar ModuleName
m) | ModuleName
m <- IndefiniteComponent -> [ModuleName]
indefc_requires IndefiniteComponent
indefc]
Right InstantiatedComponent
instc ->
[ (ModuleName
m, OpenUnitId -> ModuleName -> OpenModule
OpenModule (DefUnitId -> OpenUnitId
DefiniteUnitId DefUnitId
uid') ModuleName
m')
| (ModuleName
m, Module DefUnitId
uid' ModuleName
m') <- InstantiatedComponent -> [(ModuleName, Module)]
instc_insts InstantiatedComponent
instc
]
compat_name :: MungedPackageName
compat_name = PackageName -> LibraryName -> MungedPackageName
MungedPackageName (ReadyComponent -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName ReadyComponent
rc) (Library -> LibraryName
libName Library
lib)
compat_key :: [Char]
compat_key = Compiler -> MungedPackageName -> Version -> UnitId -> [Char]
computeCompatPackageKey Compiler
comp MungedPackageName
compat_name (ReadyComponent -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion ReadyComponent
rc) UnitId
this_uid
in LibComponentLocalBuildInfo
{ componentPackageDeps :: [(UnitId, MungedPackageId)]
componentPackageDeps = [(UnitId, MungedPackageId)]
cpds
, componentUnitId :: UnitId
componentUnitId = UnitId
this_uid
, componentComponentId :: ComponentId
componentComponentId = ComponentId
this_cid
, componentInstantiatedWith :: [(ModuleName, OpenModule)]
componentInstantiatedWith = [(ModuleName, OpenModule)]
insts
, componentIsIndefinite_ :: Bool
componentIsIndefinite_ = Bool
is_indefinite
, componentLocalName :: ComponentName
componentLocalName = ComponentName
cname
, componentInternalDeps :: [UnitId]
componentInternalDeps = [UnitId]
internal_deps
, componentExeDeps :: [UnitId]
componentExeDeps = [UnitId]
exe_deps
, componentIncludes :: [(OpenUnitId, ModuleRenaming)]
componentIncludes = [(OpenUnitId, ModuleRenaming)]
includes
, componentExposedModules :: [ExposedModule]
componentExposedModules = [ExposedModule]
exports
, componentIsPublic :: Bool
componentIsPublic = ReadyComponent -> Bool
rc_public ReadyComponent
rc
, componentCompatPackageKey :: [Char]
componentCompatPackageKey = [Char]
compat_key
, componentCompatPackageName :: MungedPackageName
componentCompatPackageName = MungedPackageName
compat_name
}
CFLib ForeignLib
_ ->
FLibComponentLocalBuildInfo
{ componentUnitId :: UnitId
componentUnitId = UnitId
this_uid
, componentComponentId :: ComponentId
componentComponentId = ComponentId
this_cid
, componentLocalName :: ComponentName
componentLocalName = ComponentName
cname
, componentPackageDeps :: [(UnitId, MungedPackageId)]
componentPackageDeps = [(UnitId, MungedPackageId)]
cpds
, componentExeDeps :: [UnitId]
componentExeDeps = [UnitId]
exe_deps
, componentInternalDeps :: [UnitId]
componentInternalDeps = [UnitId]
internal_deps
, componentIncludes :: [(OpenUnitId, ModuleRenaming)]
componentIncludes = [(OpenUnitId, ModuleRenaming)]
includes
}
CExe Executable
_ ->
ExeComponentLocalBuildInfo
{ componentUnitId :: UnitId
componentUnitId = UnitId
this_uid
, componentComponentId :: ComponentId
componentComponentId = ComponentId
this_cid
, componentLocalName :: ComponentName
componentLocalName = ComponentName
cname
, componentPackageDeps :: [(UnitId, MungedPackageId)]
componentPackageDeps = [(UnitId, MungedPackageId)]
cpds
, componentExeDeps :: [UnitId]
componentExeDeps = [UnitId]
exe_deps
, componentInternalDeps :: [UnitId]
componentInternalDeps = [UnitId]
internal_deps
, componentIncludes :: [(OpenUnitId, ModuleRenaming)]
componentIncludes = [(OpenUnitId, ModuleRenaming)]
includes
}
CTest TestSuite
_ ->
TestComponentLocalBuildInfo
{ componentUnitId :: UnitId
componentUnitId = UnitId
this_uid
, componentComponentId :: ComponentId
componentComponentId = ComponentId
this_cid
, componentLocalName :: ComponentName
componentLocalName = ComponentName
cname
, componentPackageDeps :: [(UnitId, MungedPackageId)]
componentPackageDeps = [(UnitId, MungedPackageId)]
cpds
, componentExeDeps :: [UnitId]
componentExeDeps = [UnitId]
exe_deps
, componentInternalDeps :: [UnitId]
componentInternalDeps = [UnitId]
internal_deps
, componentIncludes :: [(OpenUnitId, ModuleRenaming)]
componentIncludes = [(OpenUnitId, ModuleRenaming)]
includes
}
CBench Benchmark
_ ->
BenchComponentLocalBuildInfo
{ componentUnitId :: UnitId
componentUnitId = UnitId
this_uid
, componentComponentId :: ComponentId
componentComponentId = ComponentId
this_cid
, componentLocalName :: ComponentName
componentLocalName = ComponentName
cname
, componentPackageDeps :: [(UnitId, MungedPackageId)]
componentPackageDeps = [(UnitId, MungedPackageId)]
cpds
, componentExeDeps :: [UnitId]
componentExeDeps = [UnitId]
exe_deps
, componentInternalDeps :: [UnitId]
componentInternalDeps = [UnitId]
internal_deps
, componentIncludes :: [(OpenUnitId, ModuleRenaming)]
componentIncludes = [(OpenUnitId, ModuleRenaming)]
includes
}
where
this_uid :: UnitId
this_uid = ReadyComponent -> UnitId
rc_uid ReadyComponent
rc
this_open_uid :: OpenUnitId
this_open_uid = ReadyComponent -> OpenUnitId
rc_open_uid ReadyComponent
rc
this_cid :: ComponentId
this_cid = ReadyComponent -> ComponentId
rc_cid ReadyComponent
rc
cname :: ComponentName
cname = Component -> ComponentName
componentName (ReadyComponent -> Component
rc_component ReadyComponent
rc)
cpds :: [(UnitId, MungedPackageId)]
cpds = ReadyComponent -> [(UnitId, MungedPackageId)]
rc_depends ReadyComponent
rc
exe_deps :: [UnitId]
exe_deps = (AnnotatedId UnitId -> UnitId) -> [AnnotatedId UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map AnnotatedId UnitId -> UnitId
forall id. AnnotatedId id -> id
ann_id ([AnnotatedId UnitId] -> [UnitId])
-> [AnnotatedId UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ReadyComponent -> [AnnotatedId UnitId]
rc_exe_deps ReadyComponent
rc
is_indefinite :: Bool
is_indefinite =
case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
Left IndefiniteComponent
_ -> Bool
True
Right InstantiatedComponent
_ -> Bool
False
includes :: [(OpenUnitId, ModuleRenaming)]
includes =
(ComponentInclude OpenUnitId ModuleRenaming
-> (OpenUnitId, ModuleRenaming))
-> [ComponentInclude OpenUnitId ModuleRenaming]
-> [(OpenUnitId, ModuleRenaming)]
forall a b. (a -> b) -> [a] -> [b]
map (\ComponentInclude OpenUnitId ModuleRenaming
ci -> (ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
ci, ComponentInclude OpenUnitId ModuleRenaming -> ModuleRenaming
forall id rn. ComponentInclude id rn -> rn
ci_renaming ComponentInclude OpenUnitId ModuleRenaming
ci)) ([ComponentInclude OpenUnitId ModuleRenaming]
-> [(OpenUnitId, ModuleRenaming)])
-> [ComponentInclude OpenUnitId ModuleRenaming]
-> [(OpenUnitId, ModuleRenaming)]
forall a b. (a -> b) -> a -> b
$
case ReadyComponent -> Either IndefiniteComponent InstantiatedComponent
rc_i ReadyComponent
rc of
Left IndefiniteComponent
indefc ->
IndefiniteComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
indefc_includes IndefiniteComponent
indefc
Right InstantiatedComponent
instc ->
(ComponentInclude DefUnitId ModuleRenaming
-> ComponentInclude OpenUnitId ModuleRenaming)
-> [ComponentInclude DefUnitId ModuleRenaming]
-> [ComponentInclude OpenUnitId ModuleRenaming]
forall a b. (a -> b) -> [a] -> [b]
map
(\ComponentInclude DefUnitId ModuleRenaming
ci -> ComponentInclude DefUnitId ModuleRenaming
ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)})
(InstantiatedComponent
-> [ComponentInclude DefUnitId ModuleRenaming]
instc_includes InstantiatedComponent
instc)
internal_deps :: [UnitId]
internal_deps = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter UnitId -> Bool
isInternal (ReadyComponent -> [Key ReadyComponent]
forall a. IsNode a => a -> [Key a]
nodeNeighbors ReadyComponent
rc)