Cabal/src/Distribution/Backpack/LinkedComponent.hs

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