1{-# LANGUAGE ScopedTypeVariables #-} 2{-# LANGUAGE TypeFamilies #-} 3-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst> 4module Distribution.Backpack.LinkedComponent ( 5 LinkedComponent(..), 6 lc_insts, 7 lc_uid, 8 lc_cid, 9 lc_pkgid, 10 toLinkedComponent, 11 toLinkedComponents, 12 dispLinkedComponent, 13 LinkedComponentMap, 14 extendLinkedComponentMap, 15) where 16 17import Prelude () 18import Distribution.Compat.Prelude hiding ((<>)) 19 20import Distribution.Backpack 21import Distribution.Backpack.FullUnitId 22import Distribution.Backpack.ConfiguredComponent 23import Distribution.Backpack.ModuleShape 24import Distribution.Backpack.PreModuleShape 25import Distribution.Backpack.ModuleScope 26import Distribution.Backpack.UnifyM 27import Distribution.Backpack.MixLink 28import Distribution.Utils.MapAccum 29 30import Distribution.Types.AnnotatedId 31import Distribution.Types.ComponentName 32import Distribution.Types.ModuleReexport 33import Distribution.Types.ModuleRenaming 34import Distribution.Types.IncludeRenaming 35import Distribution.Types.ComponentInclude 36import Distribution.Types.ComponentId 37import Distribution.Types.PackageId 38import Distribution.Package 39import Distribution.PackageDescription 40import Distribution.ModuleName 41import Distribution.Simple.LocalBuildInfo 42import Distribution.Verbosity 43import Distribution.Utils.LogProgress 44 45import qualified Data.Set as Set 46import qualified Data.Map as Map 47import Distribution.Pretty (pretty) 48import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes) 49 50-- | A linked component is a component that has been mix-in linked, at 51-- which point we have determined how all the dependencies of the 52-- component are explicitly instantiated (in the form of an OpenUnitId). 53-- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which 54-- is then instantiated into 'ReadyComponent'. 55data LinkedComponent 56 = LinkedComponent { 57 -- | Uniquely identifies linked component 58 lc_ann_id :: AnnotatedId ComponentId, 59 -- | Corresponds to 'cc_component'. 60 lc_component :: Component, 61 -- | @build-tools@ and @build-tool-depends@ dependencies. 62 -- Corresponds to 'cc_exe_deps'. 63 lc_exe_deps :: [AnnotatedId OpenUnitId], 64 -- | Is this the public library of a package? Corresponds to 65 -- 'cc_public'. 66 lc_public :: Bool, 67 -- | Corresponds to 'cc_includes', but (1) this does not contain 68 -- includes of signature packages (packages with no exports), 69 -- and (2) the 'ModuleRenaming' for requirements (stored in 70 -- 'IncludeRenaming') has been removed, as it is reflected in 71 -- 'OpenUnitId'.) 72 lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming], 73 -- | Like 'lc_includes', but this specifies includes on 74 -- signature packages which have no exports. 75 lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming], 76 -- | The module shape computed by mix-in linking. This is 77 -- newly computed from 'ConfiguredComponent' 78 lc_shape :: ModuleShape 79 } 80 81-- | Uniquely identifies a 'LinkedComponent'. Corresponds to 82-- 'cc_cid'. 83lc_cid :: LinkedComponent -> ComponentId 84lc_cid = ann_id . lc_ann_id 85 86-- | Corresponds to 'cc_pkgid'. 87lc_pkgid :: LinkedComponent -> PackageId 88lc_pkgid = ann_pid . lc_ann_id 89 90-- | The 'OpenUnitId' of this component in the "default" instantiation. 91-- See also 'lc_insts'. 'LinkedComponent's cannot be instantiated 92-- (e.g., there is no 'ModSubst' instance for them). 93lc_uid :: LinkedComponent -> OpenUnitId 94lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc 95 96-- | The instantiation of 'lc_uid'; this always has the invariant 97-- that it is a mapping from a module name @A@ to @<A>@ (the hole A). 98lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] 99lc_insts lc = [ (req, OpenModuleVar req) 100 | req <- Set.toList (modShapeRequires (lc_shape lc)) ] 101 102dispLinkedComponent :: LinkedComponent -> Doc 103dispLinkedComponent lc = 104 hang (text "unit" <+> pretty (lc_uid lc)) 4 $ 105 vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) 106 | incl <- lc_includes lc ] 107 $+$ 108 vcat [ text "signature include" <+> pretty (ci_id incl) 109 | incl <- lc_sig_includes lc ] 110 $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) 111 112instance Package LinkedComponent where 113 packageId = lc_pkgid 114 115toLinkedComponent 116 :: Verbosity 117 -> FullDb 118 -> PackageId 119 -> LinkedComponentMap 120 -> ConfiguredComponent 121 -> LogProgress LinkedComponent 122toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { 123 cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, 124 cc_component = component, 125 cc_exe_deps = exe_deps, 126 cc_public = is_public, 127 cc_includes = cid_includes 128 } = do 129 let 130 -- The explicitly specified requirements, provisions and 131 -- reexports from the Cabal file. These are only non-empty for 132 -- libraries; everything else is trivial. 133 (src_reqs :: [ModuleName], 134 src_provs :: [ModuleName], 135 src_reexports :: [ModuleReexport]) = 136 case component of 137 CLib lib -> (signatures lib, 138 exposedModules lib, 139 reexportedModules lib) 140 _ -> ([], [], []) 141 src_hidden = otherModules (componentBuildInfo component) 142 143 -- Take each included ComponentId and resolve it into an 144 -- *unlinked* unit identity. We will use unification (relying 145 -- on the ModuleShape) to resolve these into linked identities. 146 unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] 147 unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i 148 | ComponentInclude dep_aid rns i <- cid_includes ] 149 150 lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) 151 lookupUid cid = fromMaybe (error "linkComponent: lookupUid") 152 (Map.lookup cid pkg_map) 153 154 let orErr (Right x) = return x 155 orErr (Left [err]) = dieProgress err 156 orErr (Left errs) = do 157 dieProgress (vcat (intersperse (text "") -- double newline! 158 [ hang (text "-") 2 err | err <- errs])) 159 160 -- Pre-shaping 161 let pre_shape = mixLinkPreModuleShape $ 162 PreModuleShape { 163 preModShapeProvides = Set.fromList (src_provs ++ src_hidden), 164 preModShapeRequires = Set.fromList src_reqs 165 } : [ renamePreModuleShape (toPreModuleShape sh) rns 166 | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ] 167 reqs = preModShapeRequires pre_shape 168 insts = [ (req, OpenModuleVar req) 169 | req <- Set.toList reqs ] 170 this_uid = IndefFullUnitId this_cid . Map.fromList $ insts 171 172 -- OK, actually do unification 173 -- TODO: the unification monad might return errors, in which 174 -- case we have to deal. Use monadic bind for now. 175 (linked_shape0 :: ModuleScope, 176 linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming], 177 linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]) 178 <- orErr $ runUnifyM verbosity this_cid db $ do 179 -- The unification monad is implemented using mutable 180 -- references. Thus, we must convert our *pure* data 181 -- structures into mutable ones to perform unification. 182 183 let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) 184 convertMod from m = do 185 m_u <- convertModule (OpenModule this_uid m) 186 return (Map.singleton m [WithSource (from m) m_u], Map.empty) 187 -- Handle 'exposed-modules' 188 exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs 189 -- Handle 'other-modules' 190 other_mod_shapes_u <- traverse (convertMod FromOtherModules) src_hidden 191 192 -- Handle 'signatures' 193 let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) 194 convertReq req = do 195 req_u <- convertModule (OpenModuleVar req) 196 return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) 197 req_shapes_u <- traverse convertReq src_reqs 198 199 -- Handle 'mixins' 200 (incl_shapes_u, all_includes_u) <- fmap unzip (traverse convertInclude unlinked_includes) 201 202 failIfErrs -- Prevent error cascade 203 -- Mix-in link everything! mixLink is the real workhorse. 204 shape_u <- mixLink $ exposed_mod_shapes_u 205 ++ other_mod_shapes_u 206 ++ req_shapes_u 207 ++ incl_shapes_u 208 209 -- src_reqs_u <- traverse convertReq src_reqs 210 -- Read out all the final results by converting back 211 -- into a pure representation. 212 let convertIncludeU (ComponentInclude dep_aid rns i) = do 213 uid <- convertUnitIdU (ann_id dep_aid) 214 return (ComponentInclude { 215 ci_ann_id = dep_aid { ann_id = uid }, 216 ci_renaming = rns, 217 ci_implicit = i 218 }) 219 shape <- convertModuleScopeU shape_u 220 let (includes_u, sig_includes_u) = partitionEithers all_includes_u 221 incls <- traverse convertIncludeU includes_u 222 sig_incls <- traverse convertIncludeU sig_includes_u 223 return (shape, incls, sig_incls) 224 225 let isNotLib (CLib _) = False 226 isNotLib _ = True 227 when (not (Set.null reqs) && isNotLib component) $ 228 dieProgress $ 229 hang (text "Non-library component has unfilled requirements:") 230 4 (vcat [pretty req | req <- Set.toList reqs]) 231 232 -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg 233 -- won't allow it (since someone could directly synthesize 234 -- an 'InstalledPackageInfo' that violates abstraction.) 235 -- Though, maybe it should be relaxed? 236 let src_hidden_set = Set.fromList src_hidden 237 linked_shape = linked_shape0 { 238 modScopeProvides = 239 -- Would rather use withoutKeys but need BC 240 Map.filterWithKey 241 (\k _ -> not (k `Set.member` src_hidden_set)) 242 (modScopeProvides linked_shape0) 243 } 244 245 -- OK, compute the reexports 246 -- TODO: This code reports the errors for reexports one reexport at 247 -- a time. Better to collect them all up and report them all at 248 -- once. 249 let hdl :: [Either Doc a] -> LogProgress [a] 250 hdl es = 251 case partitionEithers es of 252 ([], rs) -> return rs 253 (ls, _) -> 254 dieProgress $ 255 hang (text "Problem with module re-exports:") 2 256 (vcat [hang (text "-") 2 l | l <- ls]) 257 reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do 258 case Map.lookup from (modScopeProvides linked_shape) of 259 Just cands@(x0:xs0) -> do 260 -- Make sure there is at least one candidate 261 (x, xs) <- 262 case mb_pn of 263 Just pn -> 264 let matches_pn (FromMixins pn' _ _) = pn == pn' 265 matches_pn (FromBuildDepends pn' _) = pn == pn' 266 matches_pn (FromExposedModules _) = pn == packageName this_pid 267 matches_pn (FromOtherModules _) = pn == packageName this_pid 268 matches_pn (FromSignatures _) = pn == packageName this_pid 269 in case filter (matches_pn . getSource) cands of 270 (x1:xs1) -> return (x1, xs1) 271 _ -> Left (brokenReexportMsg reex) 272 Nothing -> return (x0, xs0) 273 -- Test that all the candidates are consistent 274 case filter (\x' -> unWithSource x /= unWithSource x') xs of 275 [] -> return () 276 _ -> Left $ ambiguousReexportMsg reex x xs 277 return (to, unWithSource x) 278 _ -> 279 Left (brokenReexportMsg reex) 280 281 -- TODO: maybe check this earlier; it's syntactically obvious. 282 let build_reexports m (k, v) 283 | Map.member k m = 284 dieProgress $ hsep 285 [ text "Module name ", pretty k, text " is exported multiple times." ] 286 | otherwise = return (Map.insert k v m) 287 provs <- foldM build_reexports Map.empty $ 288 -- TODO: doublecheck we have checked for 289 -- src_provs duplicates already! 290 [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ 291 reexports_list 292 293 let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) 294 295 -- See Note Note [Signature package special case] 296 let (linked_includes, linked_sig_includes) 297 | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) 298 | otherwise = (linked_includes0, linked_sig_includes0) 299 300 return $ LinkedComponent { 301 lc_ann_id = aid, 302 lc_component = component, 303 lc_public = is_public, 304 -- These must be executables 305 lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps, 306 lc_shape = final_linked_shape, 307 lc_includes = linked_includes, 308 lc_sig_includes = linked_sig_includes 309 } 310 311-- Note [Signature package special case] 312-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 313-- Suppose we have p-indef, which depends on str-sig and inherits 314-- the hole from that signature package. When we instantiate p-indef, 315-- it's a bit pointless to also go ahead and build str-sig, because 316-- str-sig cannot possibly have contributed any code to the package 317-- in question. Furthermore, because the signature was inherited to 318-- p-indef, if we test matching against p-indef, we also have tested 319-- matching against p-sig. In fact, skipping p-sig is *mandatory*, 320-- because p-indef may have thinned it (so that an implementation may 321-- match p-indef but not p-sig.) 322-- 323-- However, suppose that we have a package which mixes together str-sig 324-- and str-bytestring, with the intent of *checking* that str-sig is 325-- implemented by str-bytestring. Here, it's quite important to 326-- build an instantiated str-sig, since that is the only way we will 327-- actually end up testing if the matching works. Note that this 328-- admonition only applies if the package has NO requirements; if it 329-- has any requirements, we will typecheck it as an indefinite 330-- package, at which point the signature includes will be passed to 331-- GHC who will in turn actually do the checking to make sure they 332-- are instantiated correctly. 333 334-- Handle mix-in linking for components. In the absence of Backpack, 335-- every ComponentId gets converted into a UnitId by way of SimpleUnitId. 336toLinkedComponents 337 :: Verbosity 338 -> FullDb 339 -> PackageId 340 -> LinkedComponentMap 341 -> [ConfiguredComponent] 342 -> LogProgress [LinkedComponent] 343toLinkedComponents verbosity db this_pid lc_map0 comps 344 = fmap snd (mapAccumM go lc_map0 comps) 345 where 346 go :: Map ComponentId (OpenUnitId, ModuleShape) 347 -> ConfiguredComponent 348 -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) 349 go lc_map cc = do 350 lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ 351 toLinkedComponent verbosity db this_pid lc_map cc 352 return (extendLinkedComponentMap lc lc_map, lc) 353 354type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) 355 356extendLinkedComponentMap :: LinkedComponent 357 -> LinkedComponentMap 358 -> LinkedComponentMap 359extendLinkedComponentMap lc m = 360 Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m 361 362brokenReexportMsg :: ModuleReexport -> Doc 363brokenReexportMsg (ModuleReexport (Just pn) from _to) = 364 vcat [ text "The package" <+> quotes (pretty pn) 365 , text "does not export a module" <+> quotes (pretty from) ] 366brokenReexportMsg (ModuleReexport Nothing from _to) = 367 vcat [ text "The module" <+> quotes (pretty from) 368 , text "is not exported by any suitable package." 369 , text "It occurs in neither the 'exposed-modules' of this package," 370 , text "nor any of its 'build-depends' dependencies." ] 371 372ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc 373ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = 374 vcat [ text "Ambiguous reexport" <+> quotes (pretty from) 375 , hang (text "It could refer to either:") 2 376 (vcat (msg : msgs)) 377 , help_msg mb_pn ] 378 where 379 msg = text " " <+> displayModuleWithSource y1 380 msgs = [text "or" <+> displayModuleWithSource y | y <- ys] 381 help_msg Nothing = 382 -- TODO: This advice doesn't help if the ambiguous exports 383 -- come from a package named the same thing 384 vcat [ text "The ambiguity can be resolved by qualifying the" 385 , text "re-export with a package name." 386 , text "The syntax is 'packagename:ModuleName [as NewName]'." ] 387 -- Qualifying won't help that much. 388 help_msg (Just _) = 389 vcat [ text "The ambiguity can be resolved by using the" 390 , text "mixins field to rename one of the module" 391 , text "names differently." ] 392 displayModuleWithSource y 393 = vcat [ quotes (pretty (unWithSource y)) 394 , text "brought into scope by" <+> 395 dispModuleSource (getSource y) 396 ] 397