{-# 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.Backpack.Id

import Distribution.Simple.Compiler
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
import Distribution.ModuleName
import Distribution.Simple.Setup as Setup
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.AnnotatedId
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ComponentInclude
import Distribution.Types.MungedPackageName
import Distribution.Verbosity
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Utils.LogProgress

import Data.Either
    ( lefts )
import qualified Data.Set as Set
import qualified Data.Map as Map
import Distribution.Pretty
import Text.PrettyPrint

------------------------------------------------------------------------------
-- Pipeline
------------------------------------------------------------------------------

configureComponentLocalBuildInfos
    :: Verbosity
    -> Bool                   -- use_external_internal_deps
    -> ComponentRequestedSpec
    -> Bool                   -- deterministic
    -> Flag String            -- configIPID
    -> Flag ComponentId       -- configCID
    -> PackageDescription
    -> [PreExistingComponent]
    -> FlagAssignment         -- configConfigurationsFlags
    -> [(ModuleName, Module)] -- configInstantiateWith
    -> InstalledPackageIndex
    -> Compiler
    -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
configureComponentLocalBuildInfos :: Verbosity
-> Bool
-> ComponentRequestedSpec
-> Bool
-> Flag String
-> Flag ComponentId
-> PackageDescription
-> [PreExistingComponent]
-> FlagAssignment
-> [(ModuleName, Module)]
-> InstalledPackageIndex
-> Compiler
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
configureComponentLocalBuildInfos
    Verbosity
verbosity Bool
use_external_internal_deps ComponentRequestedSpec
enabled Bool
deterministic Flag String
ipid_flag Flag ComponentId
cid_flag PackageDescription
pkg_descr
    [PreExistingComponent]
prePkgDeps FlagAssignment
flagAssignment [(ModuleName, Module)]
instantiate_with InstalledPackageIndex
installedPackageSet Compiler
comp = do
    -- NB: In single component mode, this returns a *single* component.
    -- In this graph, the graph is NOT closed.
    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 (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 (String -> Doc
text String
"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 :: forall id.
PackageIdentifier -> ComponentName -> id -> AnnotatedId id
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]
    [ConfiguredComponent]
graph1 <- Bool
-> FlagAssignment
-> Bool
-> Flag String
-> Flag ComponentId
-> PackageDescription
-> Map PackageName (Map ComponentName (AnnotatedId ComponentId))
-> [Component]
-> LogProgress [ConfiguredComponent]
toConfiguredComponents Bool
use_external_internal_deps
                    FlagAssignment
flagAssignment
                    Bool
deterministic Flag String
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 (String -> Doc
text String
"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]
        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 = String -> FullUnitId
forall a. HasCallStack => String -> a
error (String
"uid_lookup: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
uid)
          where uid :: UnitId
uid = DefUnitId -> UnitId
unDefUnitId DefUnitId
def_uid
    [LinkedComponent]
graph2 <- Verbosity
-> (DefUnitId -> FullUnitId)
-> PackageIdentifier
-> Map ComponentId (OpenUnitId, ModuleShape)
-> [ConfiguredComponent]
-> LogProgress [LinkedComponent]
toLinkedComponents Verbosity
verbosity 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 (String -> Doc
text String
"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 (String -> Doc
text String
"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
-> PackageDescription
-> [PreExistingComponent]
-> [ReadyComponent]
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
toComponentLocalBuildInfos Compiler
comp InstalledPackageIndex
installedPackageSet PackageDescription
pkg_descr [PreExistingComponent]
prePkgDeps [ReadyComponent]
graph4

------------------------------------------------------------------------------
-- ComponentLocalBuildInfo
------------------------------------------------------------------------------

toComponentLocalBuildInfos
    :: Compiler
    -> InstalledPackageIndex -- FULL set
    -> PackageDescription
    -> [PreExistingComponent] -- external package deps
    -> [ReadyComponent]
    -> LogProgress ([ComponentLocalBuildInfo],
                    InstalledPackageIndex) -- only relevant packages
toComponentLocalBuildInfos :: Compiler
-> InstalledPackageIndex
-> PackageDescription
-> [PreExistingComponent]
-> [ReadyComponent]
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
toComponentLocalBuildInfos
    Compiler
comp InstalledPackageIndex
installedPackageSet PackageDescription
pkg_descr [PreExistingComponent]
externalPkgDeps [ReadyComponent]
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 (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 (String -> [Either InstalledPackageInfo ReadyComponent]
forall a. HasCallStack => String -> a
error String
"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 -> UnitId
forall a. IsNode a => a -> Key a
nodeKey [ReadyComponent]
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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
        [(Either InstalledPackageInfo ReadyComponent,
  [Key (Either InstalledPackageInfo ReadyComponent)])]
broken ->
          -- TODO: ppr this
          Doc -> LogProgress ()
forall a. Doc -> LogProgress a
dieProgress (Doc -> LogProgress ())
-> (String -> Doc) -> String -> LogProgress ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> LogProgress ()) -> String -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
                String
"The following packages are broken because other"
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" packages they depend on are missing. These broken "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"packages must be rebuilt before they can be used.\n"
             -- TODO: Undupe.
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [ String
"installed package "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
pkg)
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is broken due to missing package "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
forall a. Pretty a => a -> String
prettyShow [UnitId]
deps)
                        | (Left InstalledPackageInfo
pkg, [UnitId]
deps) <- [(Either InstalledPackageInfo ReadyComponent,
  [Key (Either InstalledPackageInfo ReadyComponent)])]
[(Either InstalledPackageInfo ReadyComponent, [UnitId])]
broken ]
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [ String
"planned package "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (ReadyComponent -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ReadyComponent
pkg)
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is broken due to missing package "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
forall a. Pretty a => a -> String
prettyShow [UnitId]
deps)
                        | (Right ReadyComponent
pkg, [UnitId]
deps) <- [(Either InstalledPackageInfo ReadyComponent,
  [Key (Either InstalledPackageInfo ReadyComponent)])]
[(Either InstalledPackageInfo ReadyComponent, [UnitId])]
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 :: InstalledPackageInfo
pseudoTopPkg = InstalledPackageInfo
emptyInstalledPackageInfo {
            installedUnitId :: UnitId
Installed.installedUnitId = PackageIdentifier -> UnitId
mkLegacyUnitId (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr),
            sourcePackageId :: PackageIdentifier
Installed.sourcePackageId = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr,
            depends :: [UnitId]
Installed.depends = (PreExistingComponent -> UnitId)
-> [PreExistingComponent] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map PreExistingComponent -> UnitId
pc_uid [PreExistingComponent]
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 (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 (String -> Doc
text String
"This package indirectly depends on multiple versions of the same" Doc -> Doc -> Doc
<+>
                String -> Doc
text String
"package. This is very likely to cause a compile failure.") Int
2
               ([Doc] -> Doc
vcat [ String -> Doc
text String
"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
<+> String -> Doc
text String
"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
    -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)
    ([ComponentLocalBuildInfo], InstalledPackageIndex)
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ComponentLocalBuildInfo]
clbis, InstalledPackageIndex
packageDependsIndex)

-- Build ComponentLocalBuildInfo for each component we are going
-- to build.
--
-- This conversion is lossy; we lose some invariants from ReadyComponent
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
_)
                = String -> ExposedModule
forall a. HasCallStack => String -> a
error String
"convOpenModuleExport: top-level modvar"
            exports :: [ExposedModule]
exports =
                -- Loses invariants
                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 :: String
compat_key = Compiler -> MungedPackageName -> Version -> UnitId -> String
computeCompatPackageKey Compiler
comp MungedPackageName
compat_name (ReadyComponent -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion ReadyComponent
rc) UnitId
this_uid

        in LibComponentLocalBuildInfo :: ComponentName
-> ComponentId
-> UnitId
-> Bool
-> [(ModuleName, OpenModule)]
-> [(UnitId, MungedPackageId)]
-> [(OpenUnitId, ModuleRenaming)]
-> [UnitId]
-> [UnitId]
-> String
-> MungedPackageName
-> [ExposedModule]
-> Bool
-> ComponentLocalBuildInfo
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 :: String
componentCompatPackageKey = String
compat_key,
          componentCompatPackageName :: MungedPackageName
componentCompatPackageName = MungedPackageName
compat_name
        }
      CFLib ForeignLib
_ ->
        FLibComponentLocalBuildInfo :: ComponentName
-> ComponentId
-> UnitId
-> [(UnitId, MungedPackageId)]
-> [(OpenUnitId, ModuleRenaming)]
-> [UnitId]
-> [UnitId]
-> ComponentLocalBuildInfo
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 :: ComponentName
-> ComponentId
-> UnitId
-> [(UnitId, MungedPackageId)]
-> [(OpenUnitId, ModuleRenaming)]
-> [UnitId]
-> [UnitId]
-> ComponentLocalBuildInfo
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 :: ComponentName
-> ComponentId
-> UnitId
-> [(UnitId, MungedPackageId)]
-> [(OpenUnitId, ModuleRenaming)]
-> [UnitId]
-> [UnitId]
-> ComponentLocalBuildInfo
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 :: ComponentName
-> ComponentId
-> UnitId
-> [(UnitId, MungedPackageId)]
-> [(OpenUnitId, ModuleRenaming)]
-> [UnitId]
-> [UnitId]
-> ComponentLocalBuildInfo
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 :: AnnotatedId OpenUnitId
ci_ann_id = (DefUnitId -> OpenUnitId)
-> AnnotatedId DefUnitId -> AnnotatedId OpenUnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DefUnitId -> OpenUnitId
DefiniteUnitId (ComponentInclude DefUnitId ModuleRenaming -> AnnotatedId DefUnitId
forall id rn. ComponentInclude id rn -> AnnotatedId id
ci_ann_id ComponentInclude DefUnitId ModuleRenaming
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)