{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.LinkedComponent
  ( LinkedComponent (..)
  , lc_insts
  , lc_uid
  , lc_cid
  , lc_pkgid
  , toLinkedComponent
  , toLinkedComponents
  , dispLinkedComponent
  , LinkedComponentMap
  , extendLinkedComponentMap
  ) where

import Distribution.Compat.Prelude hiding ((<>))
import Prelude ()

import Distribution.Backpack
import Distribution.Backpack.ConfiguredComponent
import Distribution.Backpack.FullUnitId
import Distribution.Backpack.MixLink
import Distribution.Backpack.ModuleScope
import Distribution.Backpack.ModuleShape
import Distribution.Backpack.PreModuleShape
import Distribution.Backpack.UnifyM
import Distribution.Utils.MapAccum

import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.AnnotatedId
import Distribution.Types.ComponentInclude
import Distribution.Utils.LogProgress
import Distribution.Verbosity

import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Pretty (pretty)
import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$))

-- | A linked component is a component that has been mix-in linked, at
-- which point we have determined how all the dependencies of the
-- component are explicitly instantiated (in the form of an OpenUnitId).
-- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which
-- is then instantiated into 'ReadyComponent'.
data LinkedComponent = LinkedComponent
  { LinkedComponent -> AnnotatedId ComponentId
lc_ann_id :: AnnotatedId ComponentId
  -- ^ Uniquely identifies linked component
  , LinkedComponent -> Component
lc_component :: Component
  -- ^ Corresponds to 'cc_component'.
  , LinkedComponent -> [AnnotatedId OpenUnitId]
lc_exe_deps :: [AnnotatedId OpenUnitId]
  -- ^ @build-tools@ and @build-tool-depends@ dependencies.
  -- Corresponds to 'cc_exe_deps'.
  , LinkedComponent -> Bool
lc_public :: Bool
  -- ^ Is this the public library of a package?  Corresponds to
  -- 'cc_public'.
  , LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
  -- ^ Corresponds to 'cc_includes', but (1) this does not contain
  -- includes of signature packages (packages with no exports),
  -- and (2) the 'ModuleRenaming' for requirements (stored in
  -- 'IncludeRenaming') has been removed, as it is reflected in
  -- 'OpenUnitId'.)
  , LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
  -- ^ Like 'lc_includes', but this specifies includes on
  -- signature packages which have no exports.
  , LinkedComponent -> ModuleShape
lc_shape :: ModuleShape
  -- ^ The module shape computed by mix-in linking.  This is
  -- newly computed from 'ConfiguredComponent'
  }

-- | Uniquely identifies a 'LinkedComponent'.  Corresponds to
-- 'cc_cid'.
lc_cid :: LinkedComponent -> ComponentId
lc_cid :: LinkedComponent -> ComponentId
lc_cid = AnnotatedId ComponentId -> ComponentId
forall id. AnnotatedId id -> id
ann_id (AnnotatedId ComponentId -> ComponentId)
-> (LinkedComponent -> AnnotatedId ComponentId)
-> LinkedComponent
-> ComponentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkedComponent -> AnnotatedId ComponentId
lc_ann_id

-- | Corresponds to 'cc_pkgid'.
lc_pkgid :: LinkedComponent -> PackageId
lc_pkgid :: LinkedComponent -> PackageId
lc_pkgid = AnnotatedId ComponentId -> PackageId
forall id. AnnotatedId id -> PackageId
ann_pid (AnnotatedId ComponentId -> PackageId)
-> (LinkedComponent -> AnnotatedId ComponentId)
-> LinkedComponent
-> PackageId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkedComponent -> AnnotatedId ComponentId
lc_ann_id

-- | The 'OpenUnitId' of this component in the "default" instantiation.
-- See also 'lc_insts'.  'LinkedComponent's cannot be instantiated
-- (e.g., there is no 'ModSubst' instance for them).
lc_uid :: LinkedComponent -> OpenUnitId
lc_uid :: LinkedComponent -> OpenUnitId
lc_uid LinkedComponent
lc = ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId (LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc) (OpenModuleSubst -> OpenUnitId)
-> ([(ModuleName, OpenModule)] -> OpenModuleSubst)
-> [(ModuleName, OpenModule)]
-> OpenUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ModuleName, OpenModule)] -> OpenUnitId)
-> [(ModuleName, OpenModule)] -> OpenUnitId
forall a b. (a -> b) -> a -> b
$ LinkedComponent -> [(ModuleName, OpenModule)]
lc_insts LinkedComponent
lc

-- | The instantiation of 'lc_uid'; this always has the invariant
-- that it is a mapping from a module name @A@ to @<A>@ (the hole A).
lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]
lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]
lc_insts LinkedComponent
lc =
  [ (ModuleName
req, ModuleName -> OpenModule
OpenModuleVar ModuleName
req)
  | ModuleName
req <- Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList (ModuleShape -> Set ModuleName
modShapeRequires (LinkedComponent -> ModuleShape
lc_shape LinkedComponent
lc))
  ]

dispLinkedComponent :: LinkedComponent -> Doc
dispLinkedComponent :: LinkedComponent -> Doc
dispLinkedComponent LinkedComponent
lc =
  Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"unit" Doc -> Doc -> Doc
<+> OpenUnitId -> Doc
forall a. Pretty a => a -> Doc
pretty (LinkedComponent -> OpenUnitId
lc_uid LinkedComponent
lc)) Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
vcat
      [ String -> Doc
text String
"include" Doc -> Doc -> Doc
<+> OpenUnitId -> Doc
forall a. Pretty a => a -> Doc
pretty (ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
incl) Doc -> Doc -> Doc
<+> ModuleRenaming -> Doc
forall a. Pretty a => a -> Doc
pretty (ComponentInclude OpenUnitId ModuleRenaming -> ModuleRenaming
forall id rn. ComponentInclude id rn -> rn
ci_renaming ComponentInclude OpenUnitId ModuleRenaming
incl)
      | ComponentInclude OpenUnitId ModuleRenaming
incl <- LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_includes LinkedComponent
lc
      ]
      Doc -> Doc -> Doc
$+$ [Doc] -> Doc
vcat
        [ String -> Doc
text String
"signature include" Doc -> Doc -> Doc
<+> OpenUnitId -> Doc
forall a. Pretty a => a -> Doc
pretty (ComponentInclude OpenUnitId ModuleRenaming -> OpenUnitId
forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
incl)
        | ComponentInclude OpenUnitId ModuleRenaming
incl <- LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_sig_includes LinkedComponent
lc
        ]
      Doc -> Doc -> Doc
$+$ OpenModuleSubst -> Doc
dispOpenModuleSubst (ModuleShape -> OpenModuleSubst
modShapeProvides (LinkedComponent -> ModuleShape
lc_shape LinkedComponent
lc))

instance Package LinkedComponent where
  packageId :: LinkedComponent -> PackageId
packageId = LinkedComponent -> PackageId
lc_pkgid

toLinkedComponent
  :: Verbosity
  -> Bool
  -- ^ Whether there are any "promised" package dependencies which we won't find already installed.
  -> FullDb
  -> PackageId
  -> LinkedComponentMap
  -> ConfiguredComponent
  -> LogProgress LinkedComponent
toLinkedComponent :: Verbosity
-> Bool
-> FullDb
-> PackageId
-> LinkedComponentMap
-> ConfiguredComponent
-> LogProgress LinkedComponent
toLinkedComponent
  Verbosity
verbosity
  Bool
anyPromised
  FullDb
db
  PackageId
this_pid
  LinkedComponentMap
pkg_map
  ConfiguredComponent
    { cc_ann_id :: ConfiguredComponent -> AnnotatedId ComponentId
cc_ann_id = aid :: AnnotatedId ComponentId
aid@AnnotatedId{ann_id :: forall id. AnnotatedId id -> id
ann_id = ComponentId
this_cid}
    , cc_component :: ConfiguredComponent -> Component
cc_component = Component
component
    , cc_exe_deps :: ConfiguredComponent -> [AnnotatedId ComponentId]
cc_exe_deps = [AnnotatedId ComponentId]
exe_deps
    , cc_public :: ConfiguredComponent -> Bool
cc_public = Bool
is_public
    , cc_includes :: ConfiguredComponent
-> [ComponentInclude ComponentId IncludeRenaming]
cc_includes = [ComponentInclude ComponentId IncludeRenaming]
cid_includes
    } = do
    let
      -- The explicitly specified requirements, provisions and
      -- reexports from the Cabal file.  These are only non-empty for
      -- libraries; everything else is trivial.
      ( [ModuleName]
src_reqs :: [ModuleName]
        , [ModuleName]
src_provs :: [ModuleName]
        , [ModuleReexport]
src_reexports :: [ModuleReexport]
        ) =
          case Component
component of
            CLib Library
lib ->
              ( Library -> [ModuleName]
signatures Library
lib
              , Library -> [ModuleName]
exposedModules Library
lib
              , Library -> [ModuleReexport]
reexportedModules Library
lib
              )
            Component
_ -> ([], [], [])
      src_hidden :: [ModuleName]
src_hidden = BuildInfo -> [ModuleName]
otherModules (Component -> BuildInfo
componentBuildInfo Component
component)

      -- Take each included ComponentId and resolve it into an
      -- \*unlinked* unit identity.  We will use unification (relying
      -- on the ModuleShape) to resolve these into linked identities.
      unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
      unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes =
        [ AnnotatedId (OpenUnitId, ModuleShape)
-> IncludeRenaming
-> Bool
-> ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
forall id rn.
AnnotatedId id -> rn -> Bool -> ComponentInclude id rn
ComponentInclude ((ComponentId -> (OpenUnitId, ModuleShape))
-> AnnotatedId ComponentId -> AnnotatedId (OpenUnitId, ModuleShape)
forall a b. (a -> b) -> AnnotatedId a -> AnnotatedId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ComponentId -> (OpenUnitId, ModuleShape)
lookupUid AnnotatedId ComponentId
dep_aid) IncludeRenaming
rns Bool
i
        | ComponentInclude AnnotatedId ComponentId
dep_aid IncludeRenaming
rns Bool
i <- [ComponentInclude ComponentId IncludeRenaming]
cid_includes
        ]

      lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
      lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
lookupUid ComponentId
cid =
        (OpenUnitId, ModuleShape)
-> Maybe (OpenUnitId, ModuleShape) -> (OpenUnitId, ModuleShape)
forall a. a -> Maybe a -> a
fromMaybe
          (String -> (OpenUnitId, ModuleShape)
forall a. HasCallStack => String -> a
error String
"linkComponent: lookupUid")
          (ComponentId
-> LinkedComponentMap -> Maybe (OpenUnitId, ModuleShape)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentId
cid LinkedComponentMap
pkg_map)

    let orErr :: Either [Doc] a -> LogProgress a
orErr (Right a
x) = a -> LogProgress a
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        orErr (Left [Doc
err]) = Doc -> LogProgress a
forall a. Doc -> LogProgress a
dieProgress Doc
err
        orErr (Left [Doc]
errs) = do
          Doc -> LogProgress a
forall a. Doc -> LogProgress a
dieProgress
            ( [Doc] -> Doc
vcat
                ( Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse
                    (String -> Doc
text String
"") -- double newline!
                    [Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"-") Int
2 Doc
err | Doc
err <- [Doc]
errs]
                )
            )

    -- Pre-shaping
    let pre_shape :: PreModuleShape
pre_shape =
          [PreModuleShape] -> PreModuleShape
mixLinkPreModuleShape ([PreModuleShape] -> PreModuleShape)
-> [PreModuleShape] -> PreModuleShape
forall a b. (a -> b) -> a -> b
$
            PreModuleShape
              { preModShapeProvides :: Set ModuleName
preModShapeProvides = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName]
src_provs [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
src_hidden)
              , preModShapeRequires :: Set ModuleName
preModShapeRequires = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList [ModuleName]
src_reqs
              }
              PreModuleShape -> [PreModuleShape] -> [PreModuleShape]
forall a. a -> [a] -> [a]
: [ PreModuleShape -> IncludeRenaming -> PreModuleShape
renamePreModuleShape (ModuleShape -> PreModuleShape
toPreModuleShape ModuleShape
sh) IncludeRenaming
rns
                | ComponentInclude (AnnotatedId{ann_id :: forall id. AnnotatedId id -> id
ann_id = (OpenUnitId
_, ModuleShape
sh)}) IncludeRenaming
rns Bool
_ <- [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes
                ]
        reqs :: Set ModuleName
reqs = PreModuleShape -> Set ModuleName
preModShapeRequires PreModuleShape
pre_shape
        insts :: [(ModuleName, OpenModule)]
insts =
          [ (ModuleName
req, ModuleName -> OpenModule
OpenModuleVar ModuleName
req)
          | ModuleName
req <- Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
reqs
          ]
        this_uid :: OpenUnitId
this_uid = ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
this_cid (OpenModuleSubst -> OpenUnitId)
-> ([(ModuleName, OpenModule)] -> OpenModuleSubst)
-> [(ModuleName, OpenModule)]
-> OpenUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ModuleName, OpenModule)] -> OpenUnitId)
-> [(ModuleName, OpenModule)] -> OpenUnitId
forall a b. (a -> b) -> a -> b
$ [(ModuleName, OpenModule)]
insts

    -- OK, actually do unification
    -- TODO: the unification monad might return errors, in which
    -- case we have to deal.  Use monadic bind for now.
    ( linked_shape0 :: ModuleScope
      , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]
      , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]
      ) <-
      Either
  [Doc]
  (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
   [ComponentInclude OpenUnitId ModuleRenaming])
-> LogProgress
     (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
      [ComponentInclude OpenUnitId ModuleRenaming])
forall {a}. Either [Doc] a -> LogProgress a
orErr (Either
   [Doc]
   (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
    [ComponentInclude OpenUnitId ModuleRenaming])
 -> LogProgress
      (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
       [ComponentInclude OpenUnitId ModuleRenaming]))
-> Either
     [Doc]
     (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
      [ComponentInclude OpenUnitId ModuleRenaming])
-> LogProgress
     (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
      [ComponentInclude OpenUnitId ModuleRenaming])
forall a b. (a -> b) -> a -> b
$ Verbosity
-> ComponentId
-> FullDb
-> (forall s.
    UnifyM
      s
      (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
       [ComponentInclude OpenUnitId ModuleRenaming]))
-> Either
     [Doc]
     (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
      [ComponentInclude OpenUnitId ModuleRenaming])
forall a.
Verbosity
-> ComponentId
-> FullDb
-> (forall s. UnifyM s a)
-> Either [Doc] a
runUnifyM Verbosity
verbosity ComponentId
this_cid FullDb
db ((forall s.
  UnifyM
    s
    (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
     [ComponentInclude OpenUnitId ModuleRenaming]))
 -> Either
      [Doc]
      (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
       [ComponentInclude OpenUnitId ModuleRenaming]))
-> (forall s.
    UnifyM
      s
      (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
       [ComponentInclude OpenUnitId ModuleRenaming]))
-> Either
     [Doc]
     (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
      [ComponentInclude OpenUnitId ModuleRenaming])
forall a b. (a -> b) -> a -> b
$ do
        -- The unification monad is implemented using mutable
        -- references.  Thus, we must convert our *pure* data
        -- structures into mutable ones to perform unification.

        let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s)
            convertMod :: forall s.
(ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod ModuleName -> ModuleSource
from ModuleName
m = do
              m_u <- OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule (OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
this_uid ModuleName
m)
              return (Map.singleton m [WithSource (from m) m_u], Map.empty)
        -- Handle 'exposed-modules'
        exposed_mod_shapes_u <- (ModuleName -> UnifyM s (ModuleScopeU s))
-> [ModuleName] -> UnifyM s [ModuleScopeU s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
forall s.
(ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod ModuleName -> ModuleSource
FromExposedModules) [ModuleName]
src_provs
        -- Handle 'other-modules'
        other_mod_shapes_u <- traverse (convertMod FromOtherModules) src_hidden

        -- Handle 'signatures'
        let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)
            convertReq ModuleName
req = do
              req_u <- OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule (ModuleName -> OpenModule
OpenModuleVar ModuleName
req)
              return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])
        req_shapes_u <- traverse convertReq src_reqs

        -- Handle 'mixins'
        (incl_shapes_u, all_includes_u) <- fmap unzip (traverse convertInclude unlinked_includes)

        failIfErrs -- Prevent error cascade
        -- Mix-in link everything!  mixLink is the real workhorse.
        shape_u <-
          mixLink $
            exposed_mod_shapes_u
              ++ other_mod_shapes_u
              ++ req_shapes_u
              ++ incl_shapes_u

        -- src_reqs_u <- traverse convertReq src_reqs
        -- Read out all the final results by converting back
        -- into a pure representation.
        let convertIncludeU (ComponentInclude AnnotatedId (UnitIdU s)
dep_aid rn
rns Bool
i) = do
              let component_name :: Doc
component_name = ComponentName -> Doc
forall a. Pretty a => a -> Doc
pretty (ComponentName -> Doc) -> ComponentName -> Doc
forall a b. (a -> b) -> a -> b
$ AnnotatedId (UnitIdU s) -> ComponentName
forall id. AnnotatedId id -> ComponentName
ann_cname AnnotatedId (UnitIdU s)
dep_aid
              uid <- UnitIdU s -> Doc -> UnifyM s OpenUnitId
forall s. UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU (AnnotatedId (UnitIdU s) -> UnitIdU s
forall id. AnnotatedId id -> id
ann_id AnnotatedId (UnitIdU s)
dep_aid) Doc
component_name
              return
                ( ComponentInclude
                    { ci_ann_id = dep_aid{ann_id = uid}
                    , ci_renaming = rns
                    , ci_implicit = i
                    }
                )

        shape <- convertModuleScopeU shape_u
        let (includes_u, sig_includes_u) = partitionEithers all_includes_u
        incls <- traverse convertIncludeU includes_u
        sig_incls <- traverse convertIncludeU sig_includes_u
        return (shape, incls, sig_incls)

    let isNotLib (CLib Library
_) = Bool
False
        isNotLib Component
_ = Bool
True
    when (not (Set.null reqs) && isNotLib component) $
      dieProgress $
        hang
          (text "Non-library component has unfilled requirements:")
          4
          (vcat [pretty req | req <- Set.toList reqs])

    -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg
    -- won't allow it (since someone could directly synthesize
    -- an 'InstalledPackageInfo' that violates abstraction.)
    -- Though, maybe it should be relaxed?
    let src_hidden_set = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList [ModuleName]
src_hidden
        linked_shape =
          ModuleScope
linked_shape0
            { modScopeProvides =
                -- Would rather use withoutKeys but need BC
                Map.filterWithKey
                  (\ModuleName
k [ModuleWithSource]
_ -> Bool -> Bool
not (ModuleName
k ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ModuleName
src_hidden_set))
                  (modScopeProvides linked_shape0)
            }

    -- OK, compute the reexports
    -- TODO: This code reports the errors for reexports one reexport at
    -- a time.  Better to collect them all up and report them all at
    -- once.
    let hdl :: [Either Doc a] -> LogProgress [a]
        hdl [Either Doc a]
es =
          case [Either Doc a] -> ([Doc], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Doc a]
es of
            ([], [a]
rs) -> [a] -> LogProgress [a]
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
rs
            ([Doc]
ls, [a]
_) ->
              Doc -> LogProgress [a]
forall a. Doc -> LogProgress a
dieProgress (Doc -> LogProgress [a]) -> Doc -> LogProgress [a]
forall a b. (a -> b) -> a -> b
$
                Doc -> Int -> Doc -> Doc
hang
                  (String -> Doc
text String
"Problem with module re-exports:")
                  Int
2
                  ([Doc] -> Doc
vcat [Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"-") Int
2 Doc
l | Doc
l <- [Doc]
ls])
    reexports_list <- hdl . (flip map) src_reexports $ \reex :: ModuleReexport
reex@(ModuleReexport Maybe PackageName
mb_pn ModuleName
from ModuleName
to) -> do
      case ModuleName
-> Map ModuleName [ModuleWithSource] -> Maybe [ModuleWithSource]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
from (ModuleScope -> Map ModuleName [ModuleWithSource]
modScopeProvides ModuleScope
linked_shape) of
        Just cands :: [ModuleWithSource]
cands@(ModuleWithSource
x0 : [ModuleWithSource]
xs0) -> do
          -- Make sure there is at least one candidate
          (x, xs) <-
            case Maybe PackageName
mb_pn of
              Just PackageName
pn ->
                let matches_pn :: ModuleSource -> Bool
matches_pn (FromMixins PackageName
pn' ComponentName
_ IncludeRenaming
_) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
pn'
                    matches_pn (FromBuildDepends PackageName
pn' ComponentName
_) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
pn'
                    matches_pn (FromExposedModules ModuleName
_) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
this_pid
                    matches_pn (FromOtherModules ModuleName
_) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
this_pid
                    matches_pn (FromSignatures ModuleName
_) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
this_pid
                 in case (ModuleWithSource -> Bool)
-> [ModuleWithSource] -> [ModuleWithSource]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleSource -> Bool
matches_pn (ModuleSource -> Bool)
-> (ModuleWithSource -> ModuleSource) -> ModuleWithSource -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleWithSource -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource) [ModuleWithSource]
cands of
                      (ModuleWithSource
x1 : [ModuleWithSource]
xs1) -> (ModuleWithSource, [ModuleWithSource])
-> Either Doc (ModuleWithSource, [ModuleWithSource])
forall a. a -> Either Doc a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleWithSource
x1, [ModuleWithSource]
xs1)
                      [ModuleWithSource]
_ -> Doc -> Either Doc (ModuleWithSource, [ModuleWithSource])
forall a b. a -> Either a b
Left (ModuleReexport -> Doc
brokenReexportMsg ModuleReexport
reex)
              Maybe PackageName
Nothing -> (ModuleWithSource, [ModuleWithSource])
-> Either Doc (ModuleWithSource, [ModuleWithSource])
forall a. a -> Either Doc a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleWithSource
x0, [ModuleWithSource]
xs0)
          -- Test that all the candidates are consistent
          case filter (\ModuleWithSource
x' -> ModuleWithSource -> OpenModule
forall a. WithSource a -> a
unWithSource ModuleWithSource
x OpenModule -> OpenModule -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleWithSource -> OpenModule
forall a. WithSource a -> a
unWithSource ModuleWithSource
x') xs of
            [] -> () -> Either Doc ()
forall a. a -> Either Doc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [ModuleWithSource]
_ -> Doc -> Either Doc ()
forall a b. a -> Either a b
Left (Doc -> Either Doc ()) -> Doc -> Either Doc ()
forall a b. (a -> b) -> a -> b
$ ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg ModuleReexport
reex ModuleWithSource
x [ModuleWithSource]
xs
          return (to, Just (unWithSource x))
        Maybe [ModuleWithSource]
_ ->
          -- Can't resolve it right now.. carry on with the assumption it will be resolved
          -- dynamically later by an in-memory package which hasn't been installed yet.
          if Bool
anyPromised
            then (ModuleName, Maybe OpenModule)
-> Either Doc (ModuleName, Maybe OpenModule)
forall a. a -> Either Doc a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
to, Maybe OpenModule
forall a. Maybe a
Nothing)
            else -- But if nothing is promised, eagerly report an error, as we already know everything.
              Doc -> Either Doc (ModuleName, Maybe OpenModule)
forall a b. a -> Either a b
Left (ModuleReexport -> Doc
brokenReexportMsg ModuleReexport
reex)

    -- TODO: maybe check this earlier; it's syntactically obvious.
    let build_reexports Map k a
m (k
k, a
v)
          | k -> Map k a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k Map k a
m =
              Doc -> LogProgress (Map k a)
forall a. Doc -> LogProgress a
dieProgress (Doc -> LogProgress (Map k a)) -> Doc -> LogProgress (Map k a)
forall a b. (a -> b) -> a -> b
$
                [Doc] -> Doc
hsep
                  [String -> Doc
text String
"Module name ", k -> Doc
forall a. Pretty a => a -> Doc
pretty k
k, String -> Doc
text String
" is exported multiple times."]
          | Bool
otherwise = Map k a -> LogProgress (Map k a)
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k a
v Map k a
m)
    provs <-
      foldM build_reexports Map.empty $
        -- TODO: doublecheck we have checked for
        -- src_provs duplicates already!
        -- These are normal module exports.
        [(mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs]
          ++
          -- These are reexports, which we managed to resolve to something in an external package.
          [(mn_new, om) | (mn_new, Just om) <- reexports_list]
          ++
          -- These ones.. we didn't resolve but also we might not have to
          -- resolve them because they could come from a promised unit,
          -- which we don't know anything about yet. GHC will resolve
          -- these itself when it is dealing with the multi-session.
          -- These ones will not be built, registered and put
          -- into a package database, we only need them to make it as far
          -- as generating GHC options where the info will be used to
          -- pass the reexported-module option to GHC.

          -- We also know that in the case there are promised units that
          -- we will not be doing anything to do with backpack like
          -- unification etc..
          [ ( mod_name
            , OpenModule
                ( DefiniteUnitId
                    ( unsafeMkDefUnitId
                        (mkUnitId "fake")
                    )
                )
                mod_name
            )
          | (mod_name, Nothing) <- reexports_list
          ]

    let final_linked_shape = OpenModuleSubst -> Set ModuleName -> ModuleShape
ModuleShape OpenModuleSubst
provs (Map ModuleName [ModuleWithSource] -> Set ModuleName
forall k a. Map k a -> Set k
Map.keysSet (ModuleScope -> Map ModuleName [ModuleWithSource]
modScopeRequires ModuleScope
linked_shape))

    -- See Note Note [Signature package special case]
    let (linked_includes, linked_sig_includes)
          | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])
          | otherwise = (linked_includes0, linked_sig_includes0)

    return $
      LinkedComponent
        { lc_ann_id = aid
        , lc_component = component
        , lc_public = is_public
        , -- These must be executables
          lc_exe_deps = map (fmap (\ComponentId
cid -> ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid OpenModuleSubst
forall k a. Map k a
Map.empty)) exe_deps
        , lc_shape = final_linked_shape
        , lc_includes = linked_includes
        , lc_sig_includes = linked_sig_includes
        }

-- Note [Signature package special case]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Suppose we have p-indef, which depends on str-sig and inherits
-- the hole from that signature package.  When we instantiate p-indef,
-- it's a bit pointless to also go ahead and build str-sig, because
-- str-sig cannot possibly have contributed any code to the package
-- in question.  Furthermore, because the signature was inherited to
-- p-indef, if we test matching against p-indef, we also have tested
-- matching against p-sig.  In fact, skipping p-sig is *mandatory*,
-- because p-indef may have thinned it (so that an implementation may
-- match p-indef but not p-sig.)
--
-- However, suppose that we have a package which mixes together str-sig
-- and str-bytestring, with the intent of *checking* that str-sig is
-- implemented by str-bytestring.  Here, it's quite important to
-- build an instantiated str-sig, since that is the only way we will
-- actually end up testing if the matching works.  Note that this
-- admonition only applies if the package has NO requirements; if it
-- has any requirements, we will typecheck it as an indefinite
-- package, at which point the signature includes will be passed to
-- GHC who will in turn actually do the checking to make sure they
-- are instantiated correctly.

-- Handle mix-in linking for components.  In the absence of Backpack,
-- every ComponentId gets converted into a UnitId by way of SimpleUnitId.
toLinkedComponents
  :: Verbosity
  -> Bool
  -- ^ Whether there are any "promised" package dependencies which we won't
  -- find already installed.
  -> FullDb
  -> PackageId
  -> LinkedComponentMap
  -> [ConfiguredComponent]
  -> LogProgress [LinkedComponent]
toLinkedComponents :: Verbosity
-> Bool
-> FullDb
-> PackageId
-> LinkedComponentMap
-> [ConfiguredComponent]
-> LogProgress [LinkedComponent]
toLinkedComponents Verbosity
verbosity Bool
anyPromised FullDb
db PackageId
this_pid LinkedComponentMap
lc_map0 [ConfiguredComponent]
comps =
  ((LinkedComponentMap, [LinkedComponent]) -> [LinkedComponent])
-> LogProgress (LinkedComponentMap, [LinkedComponent])
-> LogProgress [LinkedComponent]
forall a b. (a -> b) -> LogProgress a -> LogProgress b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LinkedComponentMap, [LinkedComponent]) -> [LinkedComponent]
forall a b. (a, b) -> b
snd ((LinkedComponentMap
 -> ConfiguredComponent
 -> LogProgress (LinkedComponentMap, LinkedComponent))
-> LinkedComponentMap
-> [ConfiguredComponent]
-> LogProgress (LinkedComponentMap, [LinkedComponent])
forall (m :: * -> *) (t :: * -> *) a b c.
(Monad m, Traversable t) =>
(a -> b -> m (a, c)) -> a -> t b -> m (a, t c)
mapAccumM LinkedComponentMap
-> ConfiguredComponent
-> LogProgress (LinkedComponentMap, LinkedComponent)
go LinkedComponentMap
lc_map0 [ConfiguredComponent]
comps)
  where
    go
      :: Map ComponentId (OpenUnitId, ModuleShape)
      -> ConfiguredComponent
      -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)
    go :: LinkedComponentMap
-> ConfiguredComponent
-> LogProgress (LinkedComponentMap, LinkedComponent)
go LinkedComponentMap
lc_map ConfiguredComponent
cc = do
      lc <-
        Doc -> LogProgress LinkedComponent -> LogProgress LinkedComponent
forall a. Doc -> LogProgress a -> LogProgress a
addProgressCtx (String -> Doc
text String
"In the stanza" Doc -> Doc -> Doc
<+> String -> Doc
text (ComponentName -> String
componentNameStanza (ConfiguredComponent -> ComponentName
cc_name ConfiguredComponent
cc))) (LogProgress LinkedComponent -> LogProgress LinkedComponent)
-> LogProgress LinkedComponent -> LogProgress LinkedComponent
forall a b. (a -> b) -> a -> b
$
          Verbosity
-> Bool
-> FullDb
-> PackageId
-> LinkedComponentMap
-> ConfiguredComponent
-> LogProgress LinkedComponent
toLinkedComponent Verbosity
verbosity Bool
anyPromised FullDb
db PackageId
this_pid LinkedComponentMap
lc_map ConfiguredComponent
cc
      return (extendLinkedComponentMap lc lc_map, lc)

type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape)

extendLinkedComponentMap
  :: LinkedComponent
  -> LinkedComponentMap
  -> LinkedComponentMap
extendLinkedComponentMap :: LinkedComponent -> LinkedComponentMap -> LinkedComponentMap
extendLinkedComponentMap LinkedComponent
lc LinkedComponentMap
m =
  ComponentId
-> (OpenUnitId, ModuleShape)
-> LinkedComponentMap
-> LinkedComponentMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (LinkedComponent -> ComponentId
lc_cid LinkedComponent
lc) (LinkedComponent -> OpenUnitId
lc_uid LinkedComponent
lc, LinkedComponent -> ModuleShape
lc_shape LinkedComponent
lc) LinkedComponentMap
m

brokenReexportMsg :: ModuleReexport -> Doc
brokenReexportMsg :: ModuleReexport -> Doc
brokenReexportMsg (ModuleReexport (Just PackageName
pn) ModuleName
from ModuleName
_to) =
  [Doc] -> Doc
vcat
    [ String -> Doc
text String
"The package" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn)
    , String -> Doc
text String
"does not export a module" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
from)
    ]
brokenReexportMsg (ModuleReexport Maybe PackageName
Nothing ModuleName
from ModuleName
_to) =
  [Doc] -> Doc
vcat
    [ String -> Doc
text String
"The module" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
from)
    , String -> Doc
text String
"is not exported by any suitable package."
    , String -> Doc
text String
"It occurs in neither the 'exposed-modules' of this package,"
    , String -> Doc
text String
"nor any of its 'build-depends' dependencies."
    ]

ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg (ModuleReexport Maybe PackageName
mb_pn ModuleName
from ModuleName
_to) ModuleWithSource
y1 [ModuleWithSource]
ys =
  [Doc] -> Doc
vcat
    [ String -> Doc
text String
"Ambiguous reexport" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
from)
    , Doc -> Int -> Doc -> Doc
hang
        (String -> Doc
text String
"It could refer to either:")
        Int
2
        ([Doc] -> Doc
vcat (Doc
msg Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
msgs))
    , Maybe PackageName -> Doc
forall {a}. Maybe a -> Doc
help_msg Maybe PackageName
mb_pn
    ]
  where
    msg :: Doc
msg = String -> Doc
text String
"  " Doc -> Doc -> Doc
<+> ModuleWithSource -> Doc
forall {a}. Pretty a => WithSource a -> Doc
displayModuleWithSource ModuleWithSource
y1
    msgs :: [Doc]
msgs = [String -> Doc
text String
"or" Doc -> Doc -> Doc
<+> ModuleWithSource -> Doc
forall {a}. Pretty a => WithSource a -> Doc
displayModuleWithSource ModuleWithSource
y | ModuleWithSource
y <- [ModuleWithSource]
ys]
    help_msg :: Maybe a -> Doc
help_msg Maybe a
Nothing =
      -- TODO: This advice doesn't help if the ambiguous exports
      -- come from a package named the same thing
      [Doc] -> Doc
vcat
        [ String -> Doc
text String
"The ambiguity can be resolved by qualifying the"
        , String -> Doc
text String
"re-export with a package name."
        , String -> Doc
text String
"The syntax is 'packagename:ModuleName [as NewName]'."
        ]
    -- Qualifying won't help that much.
    help_msg (Just a
_) =
      [Doc] -> Doc
vcat
        [ String -> Doc
text String
"The ambiguity can be resolved by using the"
        , String -> Doc
text String
"mixins field to rename one of the module"
        , String -> Doc
text String
"names differently."
        ]
    displayModuleWithSource :: WithSource a -> Doc
displayModuleWithSource WithSource a
y =
      [Doc] -> Doc
vcat
        [ Doc -> Doc
quotes (a -> Doc
forall a. Pretty a => a -> Doc
pretty (WithSource a -> a
forall a. WithSource a -> a
unWithSource WithSource a
y))
        , String -> Doc
text String
"brought into scope by"
            Doc -> Doc -> Doc
<+> ModuleSource -> Doc
dispModuleSource (WithSource a -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource WithSource a
y)
        ]