{-# 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 Prelude ()
import Distribution.Compat.Prelude hiding ((<>))

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

import Distribution.Types.AnnotatedId
import Distribution.Types.ComponentName
import Distribution.Types.ModuleRenaming
import Distribution.Types.IncludeRenaming
import Distribution.Types.ComponentInclude
import Distribution.Types.ComponentId
import Distribution.Types.PackageId
import Distribution.Package
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.Verbosity
import Distribution.Utils.LogProgress

import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Traversable
    ( mapM )
import Distribution.Pretty (pretty)
import Text.PrettyPrint
import Data.Either

-- | 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 {
        -- | Uniquely identifies linked component
        LinkedComponent -> AnnotatedId ComponentId
lc_ann_id :: AnnotatedId ComponentId,
        -- | Corresponds to 'cc_component'.
        LinkedComponent -> Component
lc_component :: Component,
        -- | @build-tools@ and @build-tool-depends@ dependencies.
        -- Corresponds to 'cc_exe_deps'.
        LinkedComponent -> [AnnotatedId OpenUnitId]
lc_exe_deps :: [AnnotatedId OpenUnitId],
        -- | Is this the public library of a package?  Corresponds to
        -- 'cc_public'.
        LinkedComponent -> Bool
lc_public :: Bool,
        -- | 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_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
        -- | Like 'lc_includes', but this specifies includes on
        -- signature packages which have no exports.
        LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
        -- | The module shape computed by mix-in linking.  This is
        -- newly computed from 'ConfiguredComponent'
        LinkedComponent -> ModuleShape
lc_shape :: ModuleShape
      }

-- | 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
    -> FullDb
    -> PackageId
    -> LinkedComponentMap
    -> ConfiguredComponent
    -> LogProgress LinkedComponent
toLinkedComponent :: Verbosity
-> FullDb
-> PackageId
-> LinkedComponentMap
-> ConfiguredComponent
-> LogProgress LinkedComponent
toLinkedComponent Verbosity
verbosity 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 (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 (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 :: Set ModuleName -> Set ModuleName -> PreModuleShape
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.
    (ModuleScope
linked_shape0  :: ModuleScope,
     [ComponentInclude OpenUnitId ModuleRenaming]
linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming],
     [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 :: (ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod ModuleName -> ModuleSource
from ModuleName
m = do
                ModuleU s
m_u <- OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule (OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
this_uid ModuleName
m)
                ModuleScopeU s -> UnifyM s (ModuleScopeU s)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
-> [WithSource (ModuleU s)]
-> Map ModuleName [WithSource (ModuleU s)]
forall k a. k -> a -> Map k a
Map.singleton ModuleName
m [ModuleSource -> ModuleU s -> WithSource (ModuleU s)
forall a. ModuleSource -> a -> WithSource a
WithSource (ModuleName -> ModuleSource
from ModuleName
m) ModuleU s
m_u], Map ModuleName [WithSource (ModuleU s)]
forall k a. Map k a
Map.empty)
        -- Handle 'exposed-modules'
        [ModuleScopeU s]
exposed_mod_shapes_u <- (ModuleName -> UnifyM s (ModuleScopeU s))
-> [ModuleName] -> UnifyM s [ModuleScopeU s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((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'
        [ModuleScopeU s]
other_mod_shapes_u <- (ModuleName -> UnifyM s (ModuleScopeU s))
-> [ModuleName] -> UnifyM s [ModuleScopeU s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
forall s.
(ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod ModuleName -> ModuleSource
FromOtherModules) [ModuleName]
src_hidden

        -- Handle 'signatures'
        let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)
            convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)
convertReq ModuleName
req = do
                ModuleU s
req_u <- OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule (ModuleName -> OpenModule
OpenModuleVar ModuleName
req)
                ModuleScopeU s -> UnifyM s (ModuleScopeU s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ModuleName [ModuleWithSourceU s]
forall k a. Map k a
Map.empty, ModuleName
-> [ModuleWithSourceU s] -> Map ModuleName [ModuleWithSourceU s]
forall k a. k -> a -> Map k a
Map.singleton ModuleName
req [ModuleSource -> ModuleU s -> ModuleWithSourceU s
forall a. ModuleSource -> a -> WithSource a
WithSource (ModuleName -> ModuleSource
FromSignatures ModuleName
req) ModuleU s
req_u])
        [ModuleScopeU s]
req_shapes_u <- (ModuleName -> UnifyM s (ModuleScopeU s))
-> [ModuleName] -> UnifyM s [ModuleScopeU s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleName -> UnifyM s (ModuleScopeU s)
forall s. ModuleName -> UnifyM s (ModuleScopeU s)
convertReq [ModuleName]
src_reqs

        -- Handle 'mixins'
        ([ModuleScopeU s]
incl_shapes_u, [Either
   (ComponentInclude (UnitIdU s) ModuleRenaming)
   (ComponentInclude (UnitIdU s) ModuleRenaming)]
all_includes_u) <- ([(ModuleScopeU s,
   Either
     (ComponentInclude (UnitIdU s) ModuleRenaming)
     (ComponentInclude (UnitIdU s) ModuleRenaming))]
 -> ([ModuleScopeU s],
     [Either
        (ComponentInclude (UnitIdU s) ModuleRenaming)
        (ComponentInclude (UnitIdU s) ModuleRenaming)]))
-> UnifyM
     s
     [(ModuleScopeU s,
       Either
         (ComponentInclude (UnitIdU s) ModuleRenaming)
         (ComponentInclude (UnitIdU s) ModuleRenaming))]
-> UnifyM
     s
     ([ModuleScopeU s],
      [Either
         (ComponentInclude (UnitIdU s) ModuleRenaming)
         (ComponentInclude (UnitIdU s) ModuleRenaming)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ModuleScopeU s,
  Either
    (ComponentInclude (UnitIdU s) ModuleRenaming)
    (ComponentInclude (UnitIdU s) ModuleRenaming))]
-> ([ModuleScopeU s],
    [Either
       (ComponentInclude (UnitIdU s) ModuleRenaming)
       (ComponentInclude (UnitIdU s) ModuleRenaming)])
forall a b. [(a, b)] -> ([a], [b])
unzip ((ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
 -> UnifyM
      s
      (ModuleScopeU s,
       Either
         (ComponentInclude (UnitIdU s) ModuleRenaming)
         (ComponentInclude (UnitIdU s) ModuleRenaming)))
-> [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
-> UnifyM
     s
     [(ModuleScopeU s,
       Either
         (ComponentInclude (UnitIdU s) ModuleRenaming)
         (ComponentInclude (UnitIdU s) ModuleRenaming))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> UnifyM
     s
     (ModuleScopeU s,
      Either
        (ComponentInclude (UnitIdU s) ModuleRenaming)
        (ComponentInclude (UnitIdU s) ModuleRenaming))
forall s.
ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> UnifyM
     s
     (ModuleScopeU s,
      Either
        (ComponentInclude (UnitIdU s) ModuleRenaming)
        (ComponentInclude (UnitIdU s) ModuleRenaming))
convertInclude [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes)

        UnifyM s ()
forall s. UnifyM s ()
failIfErrs -- Prevent error cascade
        -- Mix-in link everything!  mixLink is the real workhorse.
        ModuleScopeU s
shape_u <- [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
forall s. [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
mixLink ([ModuleScopeU s] -> UnifyM s (ModuleScopeU s))
-> [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
forall a b. (a -> b) -> a -> b
$ [ModuleScopeU s]
exposed_mod_shapes_u
                          [ModuleScopeU s] -> [ModuleScopeU s] -> [ModuleScopeU s]
forall a. [a] -> [a] -> [a]
++ [ModuleScopeU s]
other_mod_shapes_u
                          [ModuleScopeU s] -> [ModuleScopeU s] -> [ModuleScopeU s]
forall a. [a] -> [a] -> [a]
++ [ModuleScopeU s]
req_shapes_u
                          [ModuleScopeU s] -> [ModuleScopeU s] -> [ModuleScopeU s]
forall a. [a] -> [a] -> [a]
++ [ModuleScopeU s]
incl_shapes_u

        -- src_reqs_u <- mapM convertReq src_reqs
        -- Read out all the final results by converting back
        -- into a pure representation.
        let convertIncludeU :: ComponentInclude (UnitIdU s) rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
convertIncludeU (ComponentInclude AnnotatedId (UnitIdU s)
dep_aid rn
rns Bool
i) = do
                OpenUnitId
uid <- UnitIdU s -> UnifyM s OpenUnitId
forall s. UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU (AnnotatedId (UnitIdU s) -> UnitIdU s
forall id. AnnotatedId id -> id
ann_id AnnotatedId (UnitIdU s)
dep_aid)
                ComponentInclude OpenUnitId rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentInclude :: forall id rn.
AnnotatedId id -> rn -> Bool -> ComponentInclude id rn
ComponentInclude {
                            ci_ann_id :: AnnotatedId OpenUnitId
ci_ann_id = AnnotatedId (UnitIdU s)
dep_aid { ann_id :: OpenUnitId
ann_id = OpenUnitId
uid },
                            ci_renaming :: rn
ci_renaming = rn
rns,
                            ci_implicit :: Bool
ci_implicit = Bool
i
                        })
        ModuleScope
shape <- ModuleScopeU s -> UnifyM s ModuleScope
forall s. ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU ModuleScopeU s
shape_u
        let ([ComponentInclude (UnitIdU s) ModuleRenaming]
includes_u, [ComponentInclude (UnitIdU s) ModuleRenaming]
sig_includes_u) = [Either
   (ComponentInclude (UnitIdU s) ModuleRenaming)
   (ComponentInclude (UnitIdU s) ModuleRenaming)]
-> ([ComponentInclude (UnitIdU s) ModuleRenaming],
    [ComponentInclude (UnitIdU s) ModuleRenaming])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (ComponentInclude (UnitIdU s) ModuleRenaming)
   (ComponentInclude (UnitIdU s) ModuleRenaming)]
all_includes_u
        [ComponentInclude OpenUnitId ModuleRenaming]
incls <- (ComponentInclude (UnitIdU s) ModuleRenaming
 -> UnifyM s (ComponentInclude OpenUnitId ModuleRenaming))
-> [ComponentInclude (UnitIdU s) ModuleRenaming]
-> UnifyM s [ComponentInclude OpenUnitId ModuleRenaming]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ComponentInclude (UnitIdU s) ModuleRenaming
-> UnifyM s (ComponentInclude OpenUnitId ModuleRenaming)
forall s rn.
ComponentInclude (UnitIdU s) rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
convertIncludeU [ComponentInclude (UnitIdU s) ModuleRenaming]
includes_u
        [ComponentInclude OpenUnitId ModuleRenaming]
sig_incls <- (ComponentInclude (UnitIdU s) ModuleRenaming
 -> UnifyM s (ComponentInclude OpenUnitId ModuleRenaming))
-> [ComponentInclude (UnitIdU s) ModuleRenaming]
-> UnifyM s [ComponentInclude OpenUnitId ModuleRenaming]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ComponentInclude (UnitIdU s) ModuleRenaming
-> UnifyM s (ComponentInclude OpenUnitId ModuleRenaming)
forall s rn.
ComponentInclude (UnitIdU s) rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
convertIncludeU [ComponentInclude (UnitIdU s) ModuleRenaming]
sig_includes_u
        (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
 [ComponentInclude OpenUnitId ModuleRenaming])
-> UnifyM
     s
     (ModuleScope, [ComponentInclude OpenUnitId ModuleRenaming],
      [ComponentInclude OpenUnitId ModuleRenaming])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleScope
shape, [ComponentInclude OpenUnitId ModuleRenaming]
incls, [ComponentInclude OpenUnitId ModuleRenaming]
sig_incls)

    let isNotLib :: Component -> Bool
isNotLib (CLib Library
_) = Bool
False
        isNotLib Component
_        = Bool
True
    Bool -> LogProgress () -> LogProgress ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
reqs) Bool -> Bool -> Bool
&& Component -> Bool
isNotLib Component
component) (LogProgress () -> LogProgress ())
-> LogProgress () -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
        Doc -> LogProgress ()
forall a. Doc -> LogProgress a
dieProgress (Doc -> LogProgress ()) -> Doc -> LogProgress ()
forall a b. (a -> b) -> a -> b
$
            Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Non-library component has unfilled requirements:")
                Int
4 ([Doc] -> Doc
vcat [ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
req | ModuleName
req <- Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
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 :: Set ModuleName
src_hidden_set = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList [ModuleName]
src_hidden
        linked_shape :: ModuleScope
linked_shape = ModuleScope
linked_shape0 {
            modScopeProvides :: ModuleProvides
modScopeProvides =
                -- Would rather use withoutKeys but need BC
                (ModuleName -> [ModuleWithSource] -> Bool)
-> ModuleProvides -> ModuleProvides
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
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))
                    (ModuleScope -> ModuleProvides
modScopeProvides ModuleScope
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] -> 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 (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])
    [(ModuleName, OpenModule)]
reexports_list <- [Either Doc (ModuleName, OpenModule)]
-> LogProgress [(ModuleName, OpenModule)]
forall a. [Either Doc a] -> LogProgress [a]
hdl ([Either Doc (ModuleName, OpenModule)]
 -> LogProgress [(ModuleName, OpenModule)])
-> ((ModuleReexport -> Either Doc (ModuleName, OpenModule))
    -> [Either Doc (ModuleName, OpenModule)])
-> (ModuleReexport -> Either Doc (ModuleName, OpenModule))
-> LogProgress [(ModuleName, OpenModule)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((ModuleReexport -> Either Doc (ModuleName, OpenModule))
 -> [ModuleReexport] -> [Either Doc (ModuleName, OpenModule)])
-> [ModuleReexport]
-> (ModuleReexport -> Either Doc (ModuleName, OpenModule))
-> [Either Doc (ModuleName, OpenModule)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleReexport -> Either Doc (ModuleName, OpenModule))
-> [ModuleReexport] -> [Either Doc (ModuleName, OpenModule)]
forall a b. (a -> b) -> [a] -> [b]
map) [ModuleReexport]
src_reexports ((ModuleReexport -> Either Doc (ModuleName, OpenModule))
 -> LogProgress [(ModuleName, OpenModule)])
-> (ModuleReexport -> Either Doc (ModuleName, OpenModule))
-> LogProgress [(ModuleName, OpenModule)]
forall a b. (a -> b) -> a -> b
$ \reex :: ModuleReexport
reex@(ModuleReexport Maybe PackageName
mb_pn ModuleName
from ModuleName
to) -> do
      case ModuleName -> ModuleProvides -> Maybe [ModuleWithSource]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
from (ModuleScope -> ModuleProvides
modScopeProvides ModuleScope
linked_shape) of
        Just cands :: [ModuleWithSource]
cands@(ModuleWithSource
x0:[ModuleWithSource]
xs0) -> do
          -- Make sure there is at least one candidate
          (ModuleWithSource
x, [ModuleWithSource]
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (ModuleWithSource
x0, [ModuleWithSource]
xs0)
          -- Test that all the candidates are consistent
          case (ModuleWithSource -> Bool)
-> [ModuleWithSource] -> [ModuleWithSource]
forall a. (a -> Bool) -> [a] -> [a]
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') [ModuleWithSource]
xs of
            [] -> () -> Either Doc ()
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
          (ModuleName, OpenModule) -> Either Doc (ModuleName, OpenModule)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
to, ModuleWithSource -> OpenModule
forall a. WithSource a -> a
unWithSource ModuleWithSource
x)
        Maybe [ModuleWithSource]
_ ->
          Doc -> Either Doc (ModuleName, 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 -> (k, a) -> LogProgress (Map k a)
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 (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)
    OpenModuleSubst
provs <- (OpenModuleSubst
 -> (ModuleName, OpenModule) -> LogProgress OpenModuleSubst)
-> OpenModuleSubst
-> [(ModuleName, OpenModule)]
-> LogProgress OpenModuleSubst
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM OpenModuleSubst
-> (ModuleName, OpenModule) -> LogProgress OpenModuleSubst
forall k a.
(Ord k, Pretty k) =>
Map k a -> (k, a) -> LogProgress (Map k a)
build_reexports OpenModuleSubst
forall k a. Map k a
Map.empty ([(ModuleName, OpenModule)] -> LogProgress OpenModuleSubst)
-> [(ModuleName, OpenModule)] -> LogProgress OpenModuleSubst
forall a b. (a -> b) -> a -> b
$
                -- TODO: doublecheck we have checked for
                -- src_provs duplicates already!
                [ (ModuleName
mod_name, OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
this_uid ModuleName
mod_name) | ModuleName
mod_name <- [ModuleName]
src_provs ] [(ModuleName, OpenModule)]
-> [(ModuleName, OpenModule)] -> [(ModuleName, OpenModule)]
forall a. [a] -> [a] -> [a]
++
                [(ModuleName, OpenModule)]
reexports_list

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

    -- See Note Note [Signature package special case]
    let ([ComponentInclude OpenUnitId ModuleRenaming]
linked_includes, [ComponentInclude OpenUnitId ModuleRenaming]
linked_sig_includes)
            | Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
reqs = ([ComponentInclude OpenUnitId ModuleRenaming]
linked_includes0 [ComponentInclude OpenUnitId ModuleRenaming]
-> [ComponentInclude OpenUnitId ModuleRenaming]
-> [ComponentInclude OpenUnitId ModuleRenaming]
forall a. [a] -> [a] -> [a]
++ [ComponentInclude OpenUnitId ModuleRenaming]
linked_sig_includes0, [])
            | Bool
otherwise     = ([ComponentInclude OpenUnitId ModuleRenaming]
linked_includes0, [ComponentInclude OpenUnitId ModuleRenaming]
linked_sig_includes0)

    LinkedComponent -> LogProgress LinkedComponent
forall (m :: * -> *) a. Monad m => a -> m a
return (LinkedComponent -> LogProgress LinkedComponent)
-> LinkedComponent -> LogProgress LinkedComponent
forall a b. (a -> b) -> a -> b
$ LinkedComponent :: AnnotatedId ComponentId
-> Component
-> [AnnotatedId OpenUnitId]
-> Bool
-> [ComponentInclude OpenUnitId ModuleRenaming]
-> [ComponentInclude OpenUnitId ModuleRenaming]
-> ModuleShape
-> LinkedComponent
LinkedComponent {
                lc_ann_id :: AnnotatedId ComponentId
lc_ann_id = AnnotatedId ComponentId
aid,
                lc_component :: Component
lc_component = Component
component,
                lc_public :: Bool
lc_public = Bool
is_public,
                -- These must be executables
                lc_exe_deps :: [AnnotatedId OpenUnitId]
lc_exe_deps = (AnnotatedId ComponentId -> AnnotatedId OpenUnitId)
-> [AnnotatedId ComponentId] -> [AnnotatedId OpenUnitId]
forall a b. (a -> b) -> [a] -> [b]
map ((ComponentId -> OpenUnitId)
-> AnnotatedId ComponentId -> AnnotatedId OpenUnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ComponentId
cid -> ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid OpenModuleSubst
forall k a. Map k a
Map.empty)) [AnnotatedId ComponentId]
exe_deps,
                lc_shape :: ModuleShape
lc_shape = ModuleShape
final_linked_shape,
                lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
lc_includes = [ComponentInclude OpenUnitId ModuleRenaming]
linked_includes,
                lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
lc_sig_includes = [ComponentInclude OpenUnitId ModuleRenaming]
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
    -> FullDb
    -> PackageId
    -> LinkedComponentMap
    -> [ConfiguredComponent]
    -> LogProgress [LinkedComponent]
toLinkedComponents :: Verbosity
-> FullDb
-> PackageId
-> LinkedComponentMap
-> [ConfiguredComponent]
-> LogProgress [LinkedComponent]
toLinkedComponents Verbosity
verbosity FullDb
db PackageId
this_pid LinkedComponentMap
lc_map0 [ConfiguredComponent]
comps
   = ((LinkedComponentMap, [LinkedComponent]) -> [LinkedComponent])
-> LogProgress (LinkedComponentMap, [LinkedComponent])
-> LogProgress [LinkedComponent]
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
    LinkedComponent
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
-> FullDb
-> PackageId
-> LinkedComponentMap
-> ConfiguredComponent
-> LogProgress LinkedComponent
toLinkedComponent Verbosity
verbosity FullDb
db PackageId
this_pid LinkedComponentMap
lc_map ConfiguredComponent
cc
    (LinkedComponentMap, LinkedComponent)
-> LogProgress (LinkedComponentMap, LinkedComponent)
forall (m :: * -> *) a. Monad m => a -> m a
return (LinkedComponent -> LinkedComponentMap -> LinkedComponentMap
extendLinkedComponentMap LinkedComponent
lc LinkedComponentMap
lc_map, LinkedComponent
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)
             ]