{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
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)
data LinkedComponent
= LinkedComponent {
LinkedComponent -> AnnotatedId ComponentId
lc_ann_id :: AnnotatedId ComponentId,
LinkedComponent -> Component
lc_component :: Component,
LinkedComponent -> [AnnotatedId OpenUnitId]
lc_exe_deps :: [AnnotatedId OpenUnitId],
LinkedComponent -> Bool
lc_public :: Bool,
LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
LinkedComponent -> [ComponentInclude OpenUnitId ModuleRenaming]
lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
LinkedComponent -> ModuleShape
lc_shape :: ModuleShape
}
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
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
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
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
([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)
unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes = [ AnnotatedId (OpenUnitId, ModuleShape)
-> IncludeRenaming
-> Bool
-> ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
forall id rn.
AnnotatedId id -> rn -> Bool -> ComponentInclude id rn
ComponentInclude ((ComponentId -> (OpenUnitId, ModuleShape))
-> AnnotatedId ComponentId -> AnnotatedId (OpenUnitId, ModuleShape)
forall a b. (a -> b) -> AnnotatedId a -> AnnotatedId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ComponentId -> (OpenUnitId, ModuleShape)
lookupUid AnnotatedId ComponentId
dep_aid) IncludeRenaming
rns Bool
i
| ComponentInclude AnnotatedId ComponentId
dep_aid IncludeRenaming
rns Bool
i <- [ComponentInclude ComponentId IncludeRenaming]
cid_includes ]
lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
lookupUid ComponentId
cid = (OpenUnitId, ModuleShape)
-> Maybe (OpenUnitId, ModuleShape) -> (OpenUnitId, ModuleShape)
forall a. a -> Maybe a -> a
fromMaybe (String -> (OpenUnitId, ModuleShape)
forall a. HasCallStack => String -> a
error String
"linkComponent: lookupUid")
(ComponentId
-> LinkedComponentMap -> Maybe (OpenUnitId, ModuleShape)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentId
cid LinkedComponentMap
pkg_map)
let orErr :: Either [Doc] a -> LogProgress a
orErr (Right a
x) = a -> LogProgress a
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
orErr (Left [Doc
err]) = Doc -> LogProgress a
forall a. Doc -> LogProgress a
dieProgress Doc
err
orErr (Left [Doc]
errs) = do
Doc -> LogProgress a
forall a. Doc -> LogProgress a
dieProgress ([Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
"")
[ Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"-") Int
2 Doc
err | Doc
err <- [Doc]
errs]))
let pre_shape :: PreModuleShape
pre_shape = [PreModuleShape] -> PreModuleShape
mixLinkPreModuleShape ([PreModuleShape] -> PreModuleShape)
-> [PreModuleShape] -> PreModuleShape
forall a b. (a -> b) -> a -> b
$
PreModuleShape {
preModShapeProvides :: Set ModuleName
preModShapeProvides = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName]
src_provs [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
src_hidden),
preModShapeRequires :: Set ModuleName
preModShapeRequires = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList [ModuleName]
src_reqs
} PreModuleShape -> [PreModuleShape] -> [PreModuleShape]
forall a. a -> [a] -> [a]
: [ PreModuleShape -> IncludeRenaming -> PreModuleShape
renamePreModuleShape (ModuleShape -> PreModuleShape
toPreModuleShape ModuleShape
sh) IncludeRenaming
rns
| ComponentInclude (AnnotatedId { ann_id :: forall id. AnnotatedId id -> id
ann_id = (OpenUnitId
_, ModuleShape
sh) }) IncludeRenaming
rns Bool
_ <- [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes ]
reqs :: Set ModuleName
reqs = PreModuleShape -> Set ModuleName
preModShapeRequires PreModuleShape
pre_shape
insts :: [(ModuleName, OpenModule)]
insts = [ (ModuleName
req, ModuleName -> OpenModule
OpenModuleVar ModuleName
req)
| ModuleName
req <- Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
reqs ]
this_uid :: OpenUnitId
this_uid = ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
this_cid (OpenModuleSubst -> OpenUnitId)
-> ([(ModuleName, OpenModule)] -> OpenModuleSubst)
-> [(ModuleName, OpenModule)]
-> OpenUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ModuleName, OpenModule)] -> OpenUnitId)
-> [(ModuleName, OpenModule)] -> OpenUnitId
forall a b. (a -> b) -> a -> b
$ [(ModuleName, OpenModule)]
insts
(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
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 <- 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 a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
-> [ModuleWithSourceU s] -> Map ModuleName [ModuleWithSourceU s]
forall k a. k -> a -> Map k a
Map.singleton ModuleName
m [ModuleSource -> ModuleU s -> ModuleWithSourceU s
forall a. ModuleSource -> a -> WithSource a
WithSource (ModuleName -> ModuleSource
from ModuleName
m) ModuleU s
m_u], Map ModuleName [ModuleWithSourceU s]
forall k a. Map k a
Map.empty)
[ModuleScopeU s]
exposed_mod_shapes_u <- (ModuleName -> UnifyM s (ModuleScopeU s))
-> [ModuleName] -> UnifyM s [ModuleScopeU s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
forall s.
(ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod ModuleName -> ModuleSource
FromExposedModules) [ModuleName]
src_provs
[ModuleScopeU s]
other_mod_shapes_u <- (ModuleName -> UnifyM s (ModuleScopeU s))
-> [ModuleName] -> UnifyM s [ModuleScopeU s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
forall s.
(ModuleName -> ModuleSource)
-> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod ModuleName -> ModuleSource
FromOtherModules) [ModuleName]
src_hidden
let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)
convertReq :: forall s. 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 a. a -> UnifyM s a
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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ModuleName -> UnifyM s (ModuleScopeU s)
forall s. ModuleName -> UnifyM s (ModuleScopeU s)
convertReq [ModuleName]
src_reqs
([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 a b. (a -> b) -> UnifyM s a -> UnifyM s b
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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse 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
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
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 = ComponentName -> Doc
forall a. Pretty a => a -> Doc
pretty (ComponentName -> Doc) -> ComponentName -> Doc
forall a b. (a -> b) -> a -> b
$ AnnotatedId (UnitIdU s) -> ComponentName
forall id. AnnotatedId id -> ComponentName
ann_cname AnnotatedId (UnitIdU s)
dep_aid
OpenUnitId
uid <- UnitIdU s -> Doc -> UnifyM s OpenUnitId
forall s. UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU (AnnotatedId (UnitIdU s) -> UnitIdU s
forall id. AnnotatedId id -> id
ann_id AnnotatedId (UnitIdU s)
dep_aid) Doc
component_name
ComponentInclude OpenUnitId rn
-> UnifyM s (ComponentInclude OpenUnitId rn)
forall a. a -> UnifyM s a
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 = 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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse 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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse 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 a. a -> UnifyM s a
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])
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 =
Map.filterWithKey
(\ModuleName
k [ModuleWithSource]
_ -> Bool -> Bool
not (ModuleName
k ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ModuleName
src_hidden_set))
(modScopeProvides linked_shape0)
}
let hdl :: [Either Doc a] -> LogProgress [a]
hdl :: forall a. [Either Doc a] -> LogProgress [a]
hdl [Either Doc a]
es =
case [Either Doc a] -> ([Doc], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Doc a]
es of
([], [a]
rs) -> [a] -> LogProgress [a]
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
rs
([Doc]
ls, [a]
_) ->
Doc -> LogProgress [a]
forall a. Doc -> LogProgress a
dieProgress (Doc -> LogProgress [a]) -> Doc -> LogProgress [a]
forall a b. (a -> b) -> a -> b
$
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Problem with module re-exports:") Int
2
([Doc] -> Doc
vcat [Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"-") Int
2 Doc
l | Doc
l <- [Doc]
ls])
[(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
-> Map ModuleName [ModuleWithSource] -> Maybe [ModuleWithSource]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
from (ModuleScope -> Map ModuleName [ModuleWithSource]
modScopeProvides ModuleScope
linked_shape) of
Just cands :: [ModuleWithSource]
cands@(ModuleWithSource
x0:[ModuleWithSource]
xs0) -> do
(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 a. a -> Either Doc a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleWithSource
x1, [ModuleWithSource]
xs1)
[ModuleWithSource]
_ -> Doc -> Either Doc (ModuleWithSource, [ModuleWithSource])
forall a b. a -> Either a b
Left (ModuleReexport -> Doc
brokenReexportMsg ModuleReexport
reex)
Maybe PackageName
Nothing -> (ModuleWithSource, [ModuleWithSource])
-> Either Doc (ModuleWithSource, [ModuleWithSource])
forall a. a -> Either Doc a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleWithSource
x0, [ModuleWithSource]
xs0)
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 a. a -> Either Doc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[ModuleWithSource]
_ -> Doc -> Either Doc ()
forall a b. a -> Either a b
Left (Doc -> Either Doc ()) -> Doc -> Either Doc ()
forall a b. (a -> b) -> a -> b
$ ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg ModuleReexport
reex ModuleWithSource
x [ModuleWithSource]
xs
(ModuleName, OpenModule) -> Either Doc (ModuleName, OpenModule)
forall a. a -> Either Doc a
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)
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 a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k a
v Map k a
m)
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
$
[ (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 (Map ModuleName [ModuleWithSource] -> Set ModuleName
forall k a. Map k a -> Set k
Map.keysSet (ModuleScope -> Map ModuleName [ModuleWithSource]
modScopeRequires ModuleScope
linked_shape))
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 a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return (LinkedComponent -> LogProgress LinkedComponent)
-> LinkedComponent -> LogProgress LinkedComponent
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,
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 a b. (a -> b) -> AnnotatedId a -> AnnotatedId b
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
}
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 a b. (a -> b) -> LogProgress a -> LogProgress b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LinkedComponentMap, [LinkedComponent]) -> [LinkedComponent]
forall a b. (a, b) -> b
snd ((LinkedComponentMap
-> ConfiguredComponent
-> LogProgress (LinkedComponentMap, LinkedComponent))
-> LinkedComponentMap
-> [ConfiguredComponent]
-> LogProgress (LinkedComponentMap, [LinkedComponent])
forall (m :: * -> *) (t :: * -> *) a b c.
(Monad m, Traversable t) =>
(a -> b -> m (a, c)) -> a -> t b -> m (a, t c)
mapAccumM LinkedComponentMap
-> ConfiguredComponent
-> LogProgress (LinkedComponentMap, LinkedComponent)
go LinkedComponentMap
lc_map0 [ConfiguredComponent]
comps)
where
go :: Map ComponentId (OpenUnitId, ModuleShape)
-> ConfiguredComponent
-> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)
go :: LinkedComponentMap
-> ConfiguredComponent
-> LogProgress (LinkedComponentMap, LinkedComponent)
go LinkedComponentMap
lc_map ConfiguredComponent
cc = do
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 a. a -> LogProgress a
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 =
[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]'." ]
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)
]