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
data LinkedComponent
= LinkedComponent {
lc_ann_id :: AnnotatedId ComponentId,
lc_component :: Component,
lc_exe_deps :: [AnnotatedId OpenUnitId],
lc_public :: Bool,
lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
lc_shape :: ModuleShape
}
lc_cid :: LinkedComponent -> ComponentId
lc_cid = ann_id . lc_ann_id
lc_pkgid :: LinkedComponent -> PackageId
lc_pkgid = ann_pid . lc_ann_id
lc_uid :: LinkedComponent -> OpenUnitId
lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc
lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]
lc_insts lc = [ (req, OpenModuleVar req)
| req <- Set.toList (modShapeRequires (lc_shape lc)) ]
dispLinkedComponent :: LinkedComponent -> Doc
dispLinkedComponent lc =
hang (text "unit" <+> pretty (lc_uid lc)) 4 $
vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)
| incl <- lc_includes lc ]
$+$
vcat [ text "signature include" <+> pretty (ci_id incl)
| incl <- lc_sig_includes lc ]
$+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))
instance Package LinkedComponent where
packageId = lc_pkgid
toLinkedComponent
:: Verbosity
-> FullDb
-> PackageId
-> LinkedComponentMap
-> ConfiguredComponent
-> LogProgress LinkedComponent
toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
cc_ann_id = aid@AnnotatedId { ann_id = this_cid },
cc_component = component,
cc_exe_deps = exe_deps,
cc_public = is_public,
cc_includes = cid_includes
} = do
let
(src_reqs :: [ModuleName],
src_provs :: [ModuleName],
src_reexports :: [ModuleReexport]) =
case component of
CLib lib -> (signatures lib,
exposedModules lib,
reexportedModules lib)
_ -> ([], [], [])
src_hidden = otherModules (componentBuildInfo component)
unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i
| ComponentInclude dep_aid rns i <- cid_includes ]
lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
lookupUid cid = fromMaybe (error "linkComponent: lookupUid")
(Map.lookup cid pkg_map)
let orErr (Right x) = return x
orErr (Left [err]) = dieProgress err
orErr (Left errs) = do
dieProgress (vcat (intersperse (text "")
[ hang (text "-") 2 err | err <- errs]))
let pre_shape = mixLinkPreModuleShape $
PreModuleShape {
preModShapeProvides = Set.fromList (src_provs ++ src_hidden),
preModShapeRequires = Set.fromList src_reqs
} : [ renamePreModuleShape (toPreModuleShape sh) rns
| ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ]
reqs = preModShapeRequires pre_shape
insts = [ (req, OpenModuleVar req)
| req <- Set.toList reqs ]
this_uid = IndefFullUnitId this_cid . Map.fromList $ insts
(linked_shape0 :: ModuleScope,
linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming],
linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming])
<- orErr $ runUnifyM verbosity this_cid db $ do
let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod from m = do
m_u <- convertModule (OpenModule this_uid m)
return (Map.singleton m [WithSource (from m) m_u], Map.empty)
exposed_mod_shapes_u <- mapM (convertMod FromExposedModules) src_provs
other_mod_shapes_u <- mapM (convertMod FromOtherModules) src_hidden
let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)
convertReq req = do
req_u <- convertModule (OpenModuleVar req)
return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])
req_shapes_u <- mapM convertReq src_reqs
(incl_shapes_u, all_includes_u) <- fmap unzip (mapM convertInclude unlinked_includes)
failIfErrs
shape_u <- mixLink $ exposed_mod_shapes_u
++ other_mod_shapes_u
++ req_shapes_u
++ incl_shapes_u
let convertIncludeU (ComponentInclude dep_aid rns i) = do
uid <- convertUnitIdU (ann_id dep_aid)
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 <- mapM convertIncludeU includes_u
sig_incls <- mapM convertIncludeU sig_includes_u
return (shape, incls, sig_incls)
let isNotLib (CLib _) = False
isNotLib _ = 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])
let src_hidden_set = Set.fromList src_hidden
linked_shape = linked_shape0 {
modScopeProvides =
Map.filterWithKey
(\k _ -> not (k `Set.member` src_hidden_set))
(modScopeProvides linked_shape0)
}
let hdl :: [Either Doc a] -> LogProgress [a]
hdl es =
case partitionEithers es of
([], rs) -> return rs
(ls, _) ->
dieProgress $
hang (text "Problem with module re-exports:") 2
(vcat [hang (text "-") 2 l | l <- ls])
reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do
case Map.lookup from (modScopeProvides linked_shape) of
Just cands@(x0:xs0) -> do
(x, xs) <-
case mb_pn of
Just pn ->
let matches_pn (FromMixins pn' _ _) = pn == pn'
matches_pn (FromBuildDepends pn' _) = pn == pn'
matches_pn (FromExposedModules _) = pn == packageName this_pid
matches_pn (FromOtherModules _) = pn == packageName this_pid
matches_pn (FromSignatures _) = pn == packageName this_pid
in case filter (matches_pn . getSource) cands of
(x1:xs1) -> return (x1, xs1)
_ -> Left (brokenReexportMsg reex)
Nothing -> return (x0, xs0)
case filter (\x' -> unWithSource x /= unWithSource x') xs of
[] -> return ()
_ -> Left $ ambiguousReexportMsg reex x xs
return (to, unWithSource x)
_ ->
Left (brokenReexportMsg reex)
let build_reexports m (k, v)
| Map.member k m =
dieProgress $ hsep
[ text "Module name ", pretty k, text " is exported multiple times." ]
| otherwise = return (Map.insert k v m)
provs <- foldM build_reexports Map.empty $
[ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++
reexports_list
let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape))
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,
lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps,
lc_shape = final_linked_shape,
lc_includes = linked_includes,
lc_sig_includes = linked_sig_includes
}
toLinkedComponents
:: Verbosity
-> FullDb
-> PackageId
-> LinkedComponentMap
-> [ConfiguredComponent]
-> LogProgress [LinkedComponent]
toLinkedComponents verbosity db this_pid lc_map0 comps
= fmap snd (mapAccumM go lc_map0 comps)
where
go :: Map ComponentId (OpenUnitId, ModuleShape)
-> ConfiguredComponent
-> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)
go lc_map cc = do
lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $
toLinkedComponent verbosity db this_pid lc_map cc
return (extendLinkedComponentMap lc lc_map, lc)
type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape)
extendLinkedComponentMap :: LinkedComponent
-> LinkedComponentMap
-> LinkedComponentMap
extendLinkedComponentMap lc m =
Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m
brokenReexportMsg :: ModuleReexport -> Doc
brokenReexportMsg (ModuleReexport (Just pn) from _to) =
vcat [ text "The package" <+> quotes (pretty pn)
, text "does not export a module" <+> quotes (pretty from) ]
brokenReexportMsg (ModuleReexport Nothing from _to) =
vcat [ text "The module" <+> quotes (pretty from)
, text "is not exported by any suitable package."
, text "It occurs in neither the 'exposed-modules' of this package,"
, text "nor any of its 'build-depends' dependencies." ]
ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys =
vcat [ text "Ambiguous reexport" <+> quotes (pretty from)
, hang (text "It could refer to either:") 2
(vcat (msg : msgs))
, help_msg mb_pn ]
where
msg = text " " <+> displayModuleWithSource y1
msgs = [text "or" <+> displayModuleWithSource y | y <- ys]
help_msg Nothing =
vcat [ text "The ambiguity can be resolved by qualifying the"
, text "re-export with a package name."
, text "The syntax is 'packagename:ModuleName [as NewName]'." ]
help_msg (Just _) =
vcat [ text "The ambiguity can be resolved by using the"
, text "mixins field to rename one of the module"
, text "names differently." ]
displayModuleWithSource y
= vcat [ quotes (pretty (unWithSource y))
, text "brought into scope by" <+>
dispModuleSource (getSource y)
]