{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}

-- | 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 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

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

configureComponentLocalBuildInfos
  :: Verbosity
  -> Bool -- use_external_internal_deps
  -> ComponentRequestedSpec
  -> Bool -- deterministic
  -> Flag String -- configIPID
  -> Flag ComponentId -- configCID
  -> PackageDescription
  -> ([PreExistingComponent], [PromisedComponent])
  -> FlagAssignment -- configConfigurationsFlags
  -> [(ModuleName, Module)] -- configInstantiateWith
  -> 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
flags
  [(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.
    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)
    infoProgress $
      hang
        (text "Source component graph:")
        4
        (dispComponentsWithDeps graph0)

    let 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
              ]
    graph1 <-
      toConfiguredComponents
        use_external_internal_deps
        flags
        deterministic
        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 =
          [(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
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
    graph2 <-
      toLinkedComponents
        verbosity
        (not (null promisedPkgDeps))
        uid_lookup
        (package pkg_descr)
        shape_pkg_map
        graph1

    infoProgress $
      hang
        (text "Linked component graph:")
        4
        (vcat (map dispLinkedComponent graph2))

    let 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 = [(ModuleName, Module)] -> Map ModuleName Module
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ModuleName, Module)]
instantiate_with
        graph3 = Map UnitId MungedPackageId
-> Map ModuleName Module -> [LinkedComponent] -> [ReadyComponent]
toReadyComponents Map UnitId MungedPackageId
pid_map Map ModuleName Module
subst [LinkedComponent]
graph2
        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)

    infoProgress $
      hang
        (text "Ready component graph:")
        4
        (vcat (map dispReadyComponent graph4))

    toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4

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

toComponentLocalBuildInfos
  :: Compiler
  -> InstalledPackageIndex -- FULL set
  -> [PromisedComponent]
  -> PackageDescription
  -> [PreExistingComponent] -- external package deps
  -> [ReadyComponent]
  -> LogProgress
      ( [ComponentLocalBuildInfo]
      , InstalledPackageIndex -- only relevant packages
      )
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
    -- 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 ([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)
      -- 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 a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- If there are promised dependencies, we don't know what the dependencies
      -- of these are and that can easily lead to a broken graph. So assume that
      -- any promised package is not broken (ie all its dependencies, transitively,
      -- will be there). That's a promise.
      [(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 ->
            -- TODO: ppr this
            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"
                -- TODO: Undupe.
                [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
                  ]

    -- 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
            { 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
    -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)
    ([ComponentLocalBuildInfo], InstalledPackageIndex)
-> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
forall a. a -> LogProgress a
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
_) =
                [Char] -> ExposedModule
forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: [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)