{-# 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.ModuleReexport
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
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 Distribution.Pretty (pretty)
import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes)

-- | 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 = forall id. AnnotatedId id -> id
ann_id 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 = forall id. AnnotatedId id -> PackageId
ann_pid 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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList 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 <- 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
<+> forall a. Pretty a => a -> Doc
pretty (LinkedComponent -> OpenUnitId
lc_uid LinkedComponent
lc)) Int
4 forall a b. (a -> b) -> a -> b
$
         [Doc] -> Doc
vcat [ String -> Doc
text String
"include" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty (forall id rn. ComponentInclude id rn -> id
ci_id ComponentInclude OpenUnitId ModuleRenaming
incl) Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty (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
<+> forall a. Pretty a => a -> Doc
pretty (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 = [ forall id rn.
AnnotatedId id -> rn -> Bool -> ComponentInclude id rn
ComponentInclude (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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"linkComponent: lookupUid")
                                    (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) = forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        orErr (Left [Doc
err]) = forall a. Doc -> LogProgress a
dieProgress Doc
err
        orErr (Left [Doc]
errs) = do
            forall a. Doc -> LogProgress a
dieProgress ([Doc] -> Doc
vcat (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 forall a b. (a -> b) -> a -> b
$
            PreModuleShape {
                preModShapeProvides :: Set ModuleName
preModShapeProvides = forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName]
src_provs forall a. [a] -> [a] -> [a]
++ [ModuleName]
src_hidden),
                preModShapeRequires :: Set ModuleName
preModShapeRequires = forall a. Ord a => [a] -> Set a
Set.fromList [ModuleName]
src_reqs
            } 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 <- forall a. Set a -> [a]
Set.toList Set ModuleName
reqs ]
        this_uid :: OpenUnitId
this_uid = ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
this_cid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList 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])
      <- forall {a}. Either [Doc] a -> LogProgress a
orErr forall a b. (a -> b) -> a -> b
$ forall a.
Verbosity
-> ComponentId
-> FullDb
-> (forall s. UnifyM s a)
-> Either [Doc] a
runUnifyM Verbosity
verbosity ComponentId
this_cid FullDb
db 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
                ModuleU s
m_u <- forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule (OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
this_uid ModuleName
m)
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. k -> a -> Map k a
Map.singleton ModuleName
m [forall a. ModuleSource -> a -> WithSource a
WithSource (ModuleName -> ModuleSource
from ModuleName
m) ModuleU s
m_u], forall k a. Map k a
Map.empty)
        -- Handle 'exposed-modules'
        [ModuleScopeU s]
exposed_mod_shapes_u <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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 :: forall s. ModuleName -> UnifyM s (ModuleScopeU s)
convertReq ModuleName
req = do
                ModuleU s
req_u <- forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule (ModuleName -> OpenModule
OpenModuleVar ModuleName
req)
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Map k a
Map.empty, forall k a. k -> a -> Map k a
Map.singleton ModuleName
req [forall a. ModuleSource -> a -> WithSource a
WithSource (ModuleName -> ModuleSource
FromSignatures ModuleName
req) ModuleU s
req_u])
        [ModuleScopeU s]
req_shapes_u <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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)

        forall s. UnifyM s ()
failIfErrs -- Prevent error cascade
        -- Mix-in link everything!  mixLink is the real workhorse.
        ModuleScopeU s
shape_u <- forall s. [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
mixLink forall a b. (a -> b) -> a -> b
$ [ModuleScopeU s]
exposed_mod_shapes_u
                          forall a. [a] -> [a] -> [a]
++ [ModuleScopeU s]
other_mod_shapes_u
                          forall a. [a] -> [a] -> [a]
++ [ModuleScopeU s]
req_shapes_u
                          forall a. [a] -> [a] -> [a]
++ [ModuleScopeU s]
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 (UnitIdU s) rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
convertIncludeU (ComponentInclude AnnotatedId (UnitIdU s)
dep_aid rn
rns Bool
i) = do
                let component_name :: Doc
component_name = forall a. Pretty a => a -> Doc
pretty forall a b. (a -> b) -> a -> b
$ forall id. AnnotatedId id -> ComponentName
ann_cname AnnotatedId (UnitIdU s)
dep_aid
                OpenUnitId
uid <- forall s. UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU (forall id. AnnotatedId id -> id
ann_id AnnotatedId (UnitIdU s)
dep_aid) Doc
component_name
                forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- 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) = 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {s} {rn}.
ComponentInclude (UnitIdU s) rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
convertIncludeU [ComponentInclude (UnitIdU s) ModuleRenaming]
includes_u
        [ComponentInclude OpenUnitId ModuleRenaming]
sig_incls <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {s} {rn}.
ComponentInclude (UnitIdU s) rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
convertIncludeU [ComponentInclude (UnitIdU s) ModuleRenaming]
sig_includes_u
        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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set ModuleName
reqs) Bool -> Bool -> Bool
&& Component -> Bool
isNotLib Component
component) forall a b. (a -> b) -> a -> b
$
        forall a. Doc -> LogProgress a
dieProgress 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 [forall a. Pretty a => a -> Doc
pretty ModuleName
req | ModuleName
req <- 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 = 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
                forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                    (\ModuleName
k [ModuleWithSource]
_ -> Bool -> Bool
not (ModuleName
k 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 :: forall a. [Either Doc a] -> LogProgress [a]
hdl [Either Doc a]
es =
            case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Doc a]
es of
                ([], [a]
rs) -> forall (m :: * -> *) a. Monad m => a -> m a
return [a]
rs
                ([Doc]
ls, [a]
_) ->
                    forall a. Doc -> LogProgress a
dieProgress 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 <- forall a. [Either Doc a] -> LogProgress [a]
hdl forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map) [ModuleReexport]
src_reexports forall a b. (a -> b) -> a -> b
$ \reex :: ModuleReexport
reex@(ModuleReexport Maybe PackageName
mb_pn ModuleName
from ModuleName
to) -> do
      case 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 forall a. Eq a => a -> a -> Bool
== PackageName
pn'
                    matches_pn (FromBuildDepends PackageName
pn' ComponentName
_) = PackageName
pn forall a. Eq a => a -> a -> Bool
== PackageName
pn'
                    matches_pn (FromExposedModules ModuleName
_) = PackageName
pn forall a. Eq a => a -> a -> Bool
== forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
this_pid
                    matches_pn (FromOtherModules ModuleName
_)   = PackageName
pn forall a. Eq a => a -> a -> Bool
== forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
this_pid
                    matches_pn (FromSignatures ModuleName
_)     = PackageName
pn forall a. Eq a => a -> a -> Bool
== forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
this_pid
                in case forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleSource -> Bool
matches_pn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithSource a -> ModuleSource
getSource) [ModuleWithSource]
cands of
                    (ModuleWithSource
x1:[ModuleWithSource]
xs1) -> forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleWithSource
x1, [ModuleWithSource]
xs1)
                    [ModuleWithSource]
_ -> forall a b. a -> Either a b
Left (ModuleReexport -> Doc
brokenReexportMsg ModuleReexport
reex)
              Maybe PackageName
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleWithSource
x0, [ModuleWithSource]
xs0)
          -- Test that all the candidates are consistent
          case forall a. (a -> Bool) -> [a] -> [a]
filter (\ModuleWithSource
x' -> forall a. WithSource a -> a
unWithSource ModuleWithSource
x forall a. Eq a => a -> a -> Bool
/= forall a. WithSource a -> a
unWithSource ModuleWithSource
x') [ModuleWithSource]
xs of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [ModuleWithSource]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg ModuleReexport
reex ModuleWithSource
x [ModuleWithSource]
xs
          forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
to, forall a. WithSource a -> a
unWithSource ModuleWithSource
x)
        Maybe [ModuleWithSource]
_ ->
          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)
            | forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k Map k a
m =
                forall a. Doc -> LogProgress a
dieProgress forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep
                    [ String -> Doc
text String
"Module name ", forall a. Pretty a => a -> Doc
pretty k
k, String -> Doc
text String
" is exported multiple times." ]
            | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {k} {a}.
(Ord k, Pretty k) =>
Map k a -> (k, a) -> LogProgress (Map k a)
build_reexports forall k a. Map k a
Map.empty 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 ] forall a. [a] -> [a] -> [a]
++
                [(ModuleName, OpenModule)]
reexports_list

    let final_linked_shape :: ModuleShape
final_linked_shape = OpenModuleSubst -> Set ModuleName -> ModuleShape
ModuleShape OpenModuleSubst
provs (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)
            | forall a. Set a -> Bool
Set.null Set ModuleName
reqs = ([ComponentInclude OpenUnitId ModuleRenaming]
linked_includes0 forall a. [a] -> [a] -> [a]
++ [ComponentInclude OpenUnitId ModuleRenaming]
linked_sig_includes0, [])
            | Bool
otherwise     = ([ComponentInclude OpenUnitId ModuleRenaming]
linked_includes0, [ComponentInclude OpenUnitId ModuleRenaming]
linked_sig_includes0)

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ComponentId
cid -> ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid 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
   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (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 <- 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))) 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
    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 =
    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 (forall a. Pretty a => a -> Doc
pretty PackageName
pn)
       , String -> Doc
text String
"does not export a module" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (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 (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 (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 forall a. a -> [a] -> [a]
: [Doc]
msgs))
       , forall {a}. Maybe a -> Doc
help_msg Maybe PackageName
mb_pn ]
  where
    msg :: Doc
msg  = String -> Doc
text String
"  " Doc -> Doc -> Doc
<+> forall {a}. Pretty a => WithSource a -> Doc
displayModuleWithSource ModuleWithSource
y1
    msgs :: [Doc]
msgs = [String -> Doc
text String
"or" Doc -> Doc -> 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 (forall a. Pretty a => a -> Doc
pretty (forall a. WithSource a -> a
unWithSource WithSource a
y))
             , String -> Doc
text String
"brought into scope by" Doc -> Doc -> Doc
<+>
                ModuleSource -> Doc
dispModuleSource (forall a. WithSource a -> ModuleSource
getSource WithSource a
y)
             ]