Cabal/src/Distribution/Backpack/UnifyM.hs

   1 {-# LANGUAGE Rank2Types #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3
   4 -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
   5 module Distribution.Backpack.UnifyM
   6   ( -- * Unification monad
   7     UnifyM
   8   , runUnifyM
   9   , failWith
  10   , addErr
  11   , failIfErrs
  12   , tryM
  13   , addErrContext
  14   , addErrContextM
  15   , liftST
  16   , UnifEnv (..)
  17   , getUnifEnv
  18
  19     -- * Modules and unit IDs
  20   , ModuleU
  21   , ModuleU' (..)
  22   , convertModule
  23   , convertModuleU
  24   , UnitIdU
  25   , UnitIdU' (..)
  26   , convertUnitId
  27   , convertUnitIdU
  28   , ModuleSubstU
  29   , convertModuleSubstU
  30   , convertModuleSubst
  31   , ModuleScopeU
  32   , emptyModuleScopeU
  33   , convertModuleScopeU
  34   , ModuleWithSourceU
  35   , convertInclude
  36   , convertModuleProvides
  37   , convertModuleProvidesU
  38   ) where
  39
  40 import Distribution.Compat.Prelude hiding (mod)
  41 import Prelude ()
  42
  43 import Distribution.Backpack
  44 import Distribution.Backpack.FullUnitId
  45 import Distribution.Backpack.ModSubst
  46 import Distribution.Backpack.ModuleScope
  47 import Distribution.Backpack.ModuleShape
  48
  49 import Distribution.ModuleName
  50 import Distribution.Package
  51 import Distribution.PackageDescription
  52 import Distribution.Pretty
  53 import Distribution.Types.AnnotatedId
  54 import Distribution.Types.ComponentInclude
  55 import qualified Distribution.Utils.UnionFind as UnionFind
  56 import Distribution.Verbosity
  57
  58 import Control.Monad.ST
  59 import Data.IntMap (IntMap)
  60 import qualified Data.IntMap as IntMap
  61 import qualified Data.Map as Map
  62 import Data.STRef
  63 import qualified Data.Set as Set
  64 import Data.Traversable
  65 import Text.PrettyPrint
  66
  67 -- TODO: more detailed trace output on high verbosity would probably
  68 -- be appreciated by users debugging unification errors.  Collect
  69 -- some good examples!
  70
  71 data ErrMsg = ErrMsg
  72   { err_msg :: Doc
  73   , err_ctx :: [Doc]
  74   }
  75 type MsgDoc = Doc
  76
  77 renderErrMsg :: ErrMsg -> MsgDoc
  78 renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} =
  79   msg $$ vcat ctx
  80
  81 -- | The unification monad, this monad encapsulates imperative
  82 -- unification.
  83 newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)}
  84
  85 -- | Run a computation in the unification monad.
  86 runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a
  87 runUnifyM verbosity self_cid db m =
  88   runST $ do
  89     i <- newSTRef 0
  90     hmap <- newSTRef Map.empty
  91     errs <- newSTRef []
  92     mb_r <-
  93       unUnifyM
  94         m
  95         UnifEnv
  96           { unify_uniq = i
  97           , unify_reqs = hmap
  98           , unify_self_cid = self_cid
  99           , unify_verbosity = verbosity
 100           , unify_ctx = []
 101           , unify_db = db
 102           , unify_errs = errs
 103           }
 104     final_errs <- readSTRef errs
 105     case mb_r of
 106       Just x | null final_errs -> return (Right x)
 107       _ -> return (Left (map renderErrMsg (reverse final_errs)))
 108
 109 -- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'.
 110
 111 type ErrCtx s = MsgDoc
 112
 113 -- | The unification environment.
 114 data UnifEnv s = UnifEnv
 115   { unify_uniq :: UnifRef s UnitIdUnique
 116   -- ^ A supply of unique integers to label 'UnitIdU'
 117   -- cells.  This is used to determine loops in unit
 118   -- identifiers (which can happen with mutual recursion.)
 119   , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s))
 120   -- ^ The set of requirements in scope.  When
 121   -- a provision is brought into scope, we unify with
 122   -- the requirement at the same module name to fill it.
 123   -- This mapping grows monotonically.
 124   , unify_self_cid :: ComponentId
 125   -- ^ Component id of the unit we're linking.  We use this
 126   -- to detect if we fill a requirement with a local module,
 127   -- which in principle should be OK but is not currently
 128   -- supported by GHC.
 129   , unify_verbosity :: Verbosity
 130   -- ^ How verbose the error message should be
 131   , unify_ctx :: [ErrCtx s]
 132   -- ^ The error reporting context
 133   , unify_db :: FullDb
 134   -- ^ The package index for expanding unit identifiers
 135   , unify_errs :: UnifRef s [ErrMsg]
 136   -- ^ Accumulated errors
 137   }
 138
 139 instance Functor (UnifyM s) where
 140   fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)
 141
 142 instance Applicative (UnifyM s) where
 143   pure = UnifyM . pure . pure . pure
 144   UnifyM f <*> UnifyM x = UnifyM $ \r -> do
 145     f' <- f r
 146     case f' of
 147       Nothing -> return Nothing
 148       Just f'' -> do
 149         x' <- x r
 150         case x' of
 151           Nothing -> return Nothing
 152           Just x'' -> return (Just (f'' x''))
 153
 154 instance Monad (UnifyM s) where
 155   return = pure
 156   UnifyM m >>= f = UnifyM $ \r -> do
 157     x <- m r
 158     case x of
 159       Nothing -> return Nothing
 160       Just x' -> unUnifyM (f x') r
 161
 162 -- | Lift a computation from 'ST' monad to 'UnifyM' monad.
 163 -- Internal use only.
 164 liftST :: ST s a -> UnifyM s a
 165 liftST m = UnifyM $ \_ -> fmap Just m
 166
 167 addErr :: MsgDoc -> UnifyM s ()
 168 addErr msg = do
 169   env <- getUnifEnv
 170   let err =
 171         ErrMsg
 172           { err_msg = msg
 173           , err_ctx = unify_ctx env
 174           }
 175   liftST $ modifySTRef (unify_errs env) (\errs -> err : errs)
 176
 177 failWith :: MsgDoc -> UnifyM s a
 178 failWith msg = do
 179   addErr msg
 180   failM
 181
 182 failM :: UnifyM s a
 183 failM = UnifyM $ \_ -> return Nothing
 184
 185 failIfErrs :: UnifyM s ()
 186 failIfErrs = do
 187   env <- getUnifEnv
 188   errs <- liftST $ readSTRef (unify_errs env)
 189   when (not (null errs)) failM
 190
 191 tryM :: UnifyM s a -> UnifyM s (Maybe a)
 192 tryM m =
 193   UnifyM
 194     ( \env -> do
 195         mb_r <- unUnifyM m env
 196         return (Just mb_r)
 197     )
 198
 199 {-
 200 otherFail :: ErrMsg -> UnifyM s a
 201 otherFail s = UnifyM $ \_ -> return (Left s)
 202
 203 unifyFail :: ErrMsg -> UnifyM s a
 204 unifyFail err = do
 205     env <- getUnifEnv
 206     msg <- case unify_ctx env of
 207         Nothing -> return (text "Unspecified unification error:" <+> err)
 208         Just (ctx, mod1, mod2)
 209             | unify_verbosity env > normal
 210             -> do mod1' <- convertModuleU mod1
 211                   mod2' <- convertModuleU mod2
 212                   let extra = " (was unifying " ++ display mod1'
 213                                      ++ " and " ++ display mod2' ++ ")"
 214                   return (ctx ++ err ++ extra)
 215             | otherwise
 216             -> return (ctx ++ err ++ " (for more information, pass -v flag)")
 217     UnifyM $ \_ -> return (Left msg)
 218 -}
 219
 220 -- | A convenient alias for mutable references in the unification monad.
 221 type UnifRef s a = STRef s a
 222
 223 -- | Imperatively read a 'UnifRef'.
 224 readUnifRef :: UnifRef s a -> UnifyM s a
 225 readUnifRef = liftST . readSTRef
 226
 227 -- | Imperatively write a 'UnifRef'.
 228 writeUnifRef :: UnifRef s a -> a -> UnifyM s ()
 229 writeUnifRef x = liftST . writeSTRef x
 230
 231 -- | Get the current unification environment.
 232 getUnifEnv :: UnifyM s (UnifEnv s)
 233 getUnifEnv = UnifyM $ \r -> return (return r)
 234
 235 -- | Add a fixed message to the error context.
 236 addErrContext :: Doc -> UnifyM s a -> UnifyM s a
 237 addErrContext ctx m = addErrContextM ctx m
 238
 239 -- | Add a message to the error context.  It may make monadic queries.
 240 addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a
 241 addErrContextM ctx m =
 242   UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r}
 243
 244 -----------------------------------------------------------------------
 245 -- The "unifiable" variants of the data types
 246 --
 247 -- In order to properly do unification over infinite trees, we
 248 -- need to union find over 'Module's and 'UnitId's.  The pure
 249 -- representation is ill-equipped to do this, so we convert
 250 -- from the pure representation into one which is indirected
 251 -- through union-find.  'ModuleU' handles hole variables;
 252 -- 'UnitIdU' handles mu-binders.
 253
 254 -- | Contents of a mutable 'ModuleU' reference.
 255 data ModuleU' s
 256   = ModuleU (UnitIdU s) ModuleName
 257   | ModuleVarU ModuleName
 258
 259 -- | Contents of a mutable 'UnitIdU' reference.
 260 data UnitIdU' s
 261   = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))
 262   | UnitIdThunkU DefUnitId
 263
 264 -- | A mutable version of 'Module' which can be imperatively unified.
 265 type ModuleU s = UnionFind.Point s (ModuleU' s)
 266
 267 -- | A mutable version of 'UnitId' which can be imperatively unified.
 268 type UnitIdU s = UnionFind.Point s (UnitIdU' s)
 269
 270 -- | An integer for uniquely labeling 'UnitIdU' nodes.  We need
 271 -- these labels in order to efficiently serialize 'UnitIdU's into
 272 -- 'UnitId's (we use the label to check if any parent is the
 273 -- node in question, and if so insert a deBruijn index instead.)
 274 -- These labels must be unique across all 'UnitId's/'Module's which
 275 -- participate in unification!
 276 type UnitIdUnique = Int
 277
 278 -----------------------------------------------------------------------
 279 -- Conversion to the unifiable data types
 280
 281 -- An environment for tracking the mu-bindings in scope.
 282 -- The invariant for a state @(m, i)@ is that [0..i] are
 283 -- keys of @m@; in fact, the @i-k@th entry is the @k@th
 284 -- de Bruijn index (this saves us from having to shift as
 285 -- we enter mu-binders.)
 286 type MuEnv s = (IntMap (UnitIdU s), Int)
 287
 288 extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s
 289 extendMuEnv (m, i) x =
 290   (IntMap.insert (i + 1) x m, i + 1)
 291
 292 {-
 293 lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s
 294 lookupMuEnv (m, i) k =
 295     case IntMap.lookup (i - k) m of
 296         -- Technically a user can trigger this by giving us a
 297         -- bad 'UnitId', so handle this better.
 298         Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)"
 299         Just v -> v
 300 -}
 301
 302 emptyMuEnv :: MuEnv s
 303 emptyMuEnv = (IntMap.empty, -1)
 304
 305 -- The workhorse functions.  These share an environment:
 306 --   * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes
 307 --   * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized)
 308 --     environment containing the implicitly universally quantified
 309 --     @hole:A@ binders.
 310 --   * @MuEnv@ - the environment for mu-binders.
 311
 312 convertUnitId'
 313   :: MuEnv s
 314   -> OpenUnitId
 315   -> UnifyM s (UnitIdU s)
 316 -- TODO: this could be more lazy if we know there are no internal
 317 -- references
 318 convertUnitId' _ (DefiniteUnitId uid) =
 319   liftST $ UnionFind.fresh (UnitIdThunkU uid)
 320 convertUnitId' stk (IndefFullUnitId cid insts) = do
 321   fs <- fmap unify_uniq getUnifEnv
 322   x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later
 323   insts_u <- for insts $ convertModule' (extendMuEnv stk x)
 324   u <- readUnifRef fs
 325   writeUnifRef fs (u + 1)
 326   y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)
 327   liftST $ UnionFind.union x y
 328   return y
 329
 330 -- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i)
 331
 332 convertModule'
 333   :: MuEnv s
 334   -> OpenModule
 335   -> UnifyM s (ModuleU s)
 336 convertModule' _stk (OpenModuleVar mod_name) = do
 337   hmap <- fmap unify_reqs getUnifEnv
 338   hm <- readUnifRef hmap
 339   case Map.lookup mod_name hm of
 340     Nothing -> do
 341       mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)
 342       writeUnifRef hmap (Map.insert mod_name mod hm)
 343       return mod
 344     Just mod -> return mod
 345 convertModule' stk (OpenModule uid mod_name) = do
 346   uid_u <- convertUnitId' stk uid
 347   liftST $ UnionFind.fresh (ModuleU uid_u mod_name)
 348
 349 convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s)
 350 convertUnitId = convertUnitId' emptyMuEnv
 351
 352 convertModule :: OpenModule -> UnifyM s (ModuleU s)
 353 convertModule = convertModule' emptyMuEnv
 354
 355 -----------------------------------------------------------------------
 356 -- Substitutions
 357
 358 -- | The mutable counterpart of a 'ModuleSubst' (not defined here).
 359 type ModuleSubstU s = Map ModuleName (ModuleU s)
 360
 361 -- | Conversion of 'ModuleSubst' to 'ModuleSubstU'
 362 convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s))
 363 convertModuleSubst = traverse convertModule
 364
 365 -- | Conversion of 'ModuleSubstU' to 'ModuleSubst'
 366 convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst
 367 convertModuleSubstU = traverse convertModuleU
 368
 369 -----------------------------------------------------------------------
 370 -- Conversion from the unifiable data types
 371
 372 -- An environment for tracking candidates for adding a mu-binding.
 373 -- The invariant for a state @(m, i)@, is that if we encounter a node
 374 -- labeled @k@ such that @m[k -> v]@, then we can replace this
 375 -- node with the de Bruijn index @i-v@ referring to an enclosing
 376 -- mu-binder; furthermore, @range(m) = [0..i]@.
 377 type MooEnv = (IntMap Int, Int)
 378
 379 emptyMooEnv :: MooEnv
 380 emptyMooEnv = (IntMap.empty, -1)
 381
 382 extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv
 383 extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1)
 384
 385 lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int
 386 lookupMooEnv (m, i) k =
 387   case IntMap.lookup k m of
 388     Nothing -> Nothing
 389     Just v -> Just (i - v) -- de Bruijn indexize
 390
 391 -- The workhorse functions
 392
 393 -- | Returns `OpenUnitId` if there is no a mutually recursive unit.
 394 -- | Otherwise returns a list of signatures instantiated by given `UnitIdU`.
 395 convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
 396 convertUnitIdU' stk uid_u required_mod_name = do
 397   x <- liftST $ UnionFind.find uid_u
 398   case x of
 399     UnitIdThunkU uid -> return $ DefiniteUnitId uid
 400     UnitIdU u cid insts_u ->
 401       case lookupMooEnv stk u of
 402         Just _ ->
 403           let mod_names = Map.keys insts_u
 404            in failWithMutuallyRecursiveUnitsError required_mod_name mod_names
 405         Nothing -> do
 406           insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)
 407           return $ IndefFullUnitId cid insts
 408
 409 convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule
 410 convertModuleU' stk mod_u = do
 411   mod <- liftST $ UnionFind.find mod_u
 412   case mod of
 413     ModuleVarU mod_name -> return (OpenModuleVar mod_name)
 414     ModuleU uid_u mod_name -> do
 415       uid <- convertUnitIdU' stk uid_u (pretty mod_name)
 416       return (OpenModule uid mod_name)
 417
 418 failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a
 419 failWithMutuallyRecursiveUnitsError required_mod_name mod_names =
 420   let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names
 421    in failWith $
 422         text "Cannot instantiate requirement"
 423           <+> quotes required_mod_name
 424           $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:"
 425           <+> sigsList
 426           $$ text "as this creates a cyclic dependency, which GHC does not support."
 427
 428 -- Helper functions
 429
 430 convertUnitIdU :: UnitIdU s -> Doc -> UnifyM s OpenUnitId
 431 convertUnitIdU = convertUnitIdU' emptyMooEnv
 432
 433 convertModuleU :: ModuleU s -> UnifyM s OpenModule
 434 convertModuleU = convertModuleU' emptyMooEnv
 435
 436 -- | An empty 'ModuleScopeU'.
 437 emptyModuleScopeU :: ModuleScopeU s
 438 emptyModuleScopeU = (Map.empty, Map.empty)
 439
 440 -- | The mutable counterpart of 'ModuleScope'.
 441 type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s)
 442
 443 -- | The mutable counterpart of 'ModuleProvides'
 444 type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s]
 445
 446 type ModuleRequiresU s = ModuleProvidesU s
 447 type ModuleWithSourceU s = WithSource (ModuleU s)
 448
 449 -- TODO: Deduplicate this with Distribution.Backpack.MixLink.dispSource
 450 ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc
 451 ci_msg ci
 452   | ci_implicit ci = text "build-depends:" <+> pp_pn
 453   | otherwise = text "mixins:" <+> pp_pn <+> pretty (ci_renaming ci)
 454   where
 455     pn = pkgName (ci_pkgid ci)
 456     pp_pn =
 457       case ci_cname ci of
 458         CLibName LMainLibName -> pretty pn
 459         CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn
 460         -- Shouldn't happen
 461         cn -> pretty pn <+> parens (pretty cn)
 462
 463 -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do
 464 -- unification on it.
 465 convertInclude
 466   :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
 467   -> UnifyM
 468       s
 469       ( ModuleScopeU s
 470       , Either
 471           (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -})
 472           (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -})
 473       )
 474 convertInclude
 475   ci@( ComponentInclude
 476         { ci_ann_id =
 477           AnnotatedId
 478             { ann_id = (uid, ModuleShape provs reqs)
 479             , ann_pid = pid
 480             , ann_cname = compname
 481             }
 482         , ci_renaming = incl@(IncludeRenaming prov_rns req_rns)
 483         , ci_implicit = implicit
 484         }
 485       ) = addErrContext (text "In" <+> ci_msg ci) $ do
 486     let pn = packageName pid
 487         the_source
 488           | implicit =
 489               FromBuildDepends pn compname
 490           | otherwise =
 491               FromMixins pn compname incl
 492         source = WithSource the_source
 493
 494     -- Suppose our package has two requirements A and B, and
 495     -- we include it with @requires (A as X)@
 496     -- There are three closely related things we compute based
 497     -- off of @reqs@ and @reqs_rns@:
 498     --
 499     --      1. The requirement renaming (A -> X)
 500     --      2. The requirement substitution (A -> <X>, B -> <B>)
 501
 502     -- Requirement renaming.  This is read straight off the syntax:
 503     --
 504     --      [nothing]          ==>  [empty]
 505     --      requires (B as Y)  ==>  B -> Y
 506     --
 507     -- Requirement renamings are NOT injective: if two requirements
 508     -- are mapped to the same name, the intent is to merge them
 509     -- together.  But they are *functions*, so @B as X, B as Y@ is
 510     -- illegal.
 511
 512     req_rename_list <-
 513       case req_rns of
 514         DefaultRenaming -> return []
 515         HidingRenaming _ -> do
 516           -- Not valid here for requires!
 517           addErr $
 518             text "Unsupported syntax"
 519               <+> quotes (text "requires hiding (...)")
 520           return []
 521         ModuleRenaming rns -> return rns
 522
 523     let req_rename_listmap :: Map ModuleName [ModuleName]
 524         req_rename_listmap =
 525           Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list]
 526     req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 ->
 527       case vs0 of
 528         [] -> error "req_rename"
 529         [v] -> return v
 530         v : vs -> do
 531           addErr $
 532             text "Conflicting renamings of requirement"
 533               <+> quotes (pretty k)
 534               $$ text "Renamed to: "
 535               <+> vcat (map pretty (v : vs))
 536           return v
 537
 538     let req_rename_fn k = case Map.lookup k req_rename of
 539           Nothing -> k
 540           Just v -> v
 541
 542     -- Requirement substitution.
 543     --
 544     --      A -> X      ==>     A -> <X>
 545     let req_subst = fmap OpenModuleVar req_rename
 546
 547     uid_u <- convertUnitId (modSubst req_subst uid)
 548
 549     -- Requirement mapping.  This is just taking the range of the
 550     -- requirement substitution, and making a mapping so that it is
 551     -- convenient to merge things together.  It INCLUDES the implicit
 552     -- mappings.
 553     --
 554     --      A -> X      ==>     X -> <X>, B -> <B>
 555     reqs_u <-
 556       convertModuleRequires . Map.fromList $
 557         [ (k, [source (OpenModuleVar k)])
 558         | k <- map req_rename_fn (Set.toList reqs)
 559         ]
 560
 561     -- Report errors if there were unused renamings
 562     let leftover = Map.keysSet req_rename `Set.difference` reqs
 563     unless (Set.null leftover) $
 564       addErr $
 565         hang
 566           ( text "The"
 567               <+> text (showComponentName compname)
 568               <+> text "from package"
 569               <+> quotes (pretty pid)
 570               <+> text "does not require:"
 571           )
 572           4
 573           (vcat (map pretty (Set.toList leftover)))
 574
 575     -- Provision computation is more complex.
 576     -- For example, if we have:
 577     --
 578     --      include p (A as X) requires (B as Y)
 579     --          where A -> q[B=<B>]:A
 580     --
 581     -- Then we need:
 582     --
 583     --      X -> [("p", q[B=<B>]:A)]
 584     --
 585     -- There are a bunch of clever ways to present the algorithm
 586     -- but here is the simple one:
 587     --
 588     --      1. If we have a default renaming, apply req_subst
 589     --      to provs and use that.
 590     --
 591     --      2. Otherwise, build a map by successively looking
 592     --      up the referenced modules in the renaming in provs.
 593     --
 594     -- Importantly, overlapping rename targets get accumulated
 595     -- together.  It's not an (immediate) error.
 596     (pre_prov_scope, prov_rns') <-
 597       case prov_rns of
 598         DefaultRenaming -> return (Map.toList provs, prov_rns)
 599         HidingRenaming hides ->
 600           let hides_set = Set.fromList hides
 601            in let r =
 602                     [ (k, v)
 603                     | (k, v) <- Map.toList provs
 604                     , not (k `Set.member` hides_set)
 605                     ]
 606                in -- GHC doesn't understand hiding, so expand it out!
 607                   return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r))
 608         ModuleRenaming rns -> do
 609           r <-
 610             sequence
 611               [ case Map.lookup from provs of
 612                 Just m -> return (to, m)
 613                 Nothing ->
 614                   failWith $
 615                     text "Package"
 616                       <+> quotes (pretty pid)
 617                       <+> text "does not expose the module"
 618                       <+> quotes (pretty from)
 619               | (from, to) <- rns
 620               ]
 621           return (r, prov_rns)
 622     let prov_scope =
 623           modSubst req_subst $
 624             Map.fromListWith
 625               (++)
 626               [ (k, [source v])
 627               | (k, v) <- pre_prov_scope
 628               ]
 629
 630     provs_u <- convertModuleProvides prov_scope
 631
 632     -- TODO: Assert that provs_u is empty if provs was empty
 633     return
 634       ( (provs_u, reqs_u)
 635       , -- NB: We test that requirements is not null so that
 636         -- users can create packages with zero module exports
 637         -- that cause some C library to linked in, etc.
 638         ( if Map.null provs && not (Set.null reqs)
 639             then Right -- is sig
 640             else Left
 641         )
 642           ( ComponentInclude
 643               { ci_ann_id =
 644                   AnnotatedId
 645                     { ann_id = uid_u
 646                     , ann_pid = pid
 647                     , ann_cname = compname
 648                     }
 649               , ci_renaming = prov_rns'
 650               , ci_implicit = ci_implicit ci
 651               }
 652           )
 653       )
 654
 655 -- | Convert a 'ModuleScopeU' to a 'ModuleScope'.
 656 convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope
 657 convertModuleScopeU (provs_u, reqs_u) = do
 658   provs <- convertModuleProvidesU provs_u
 659   reqs <- convertModuleRequiresU reqs_u
 660   -- TODO: Test that the requirements are still free. If they
 661   -- are not, they got unified, and that's dodgy at best.
 662   return (ModuleScope provs reqs)
 663
 664 -- | Convert a 'ModuleProvides' to a 'ModuleProvidesU'
 665 convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
 666 convertModuleProvides = traverse (traverse (traverse convertModule))
 667
 668 -- | Convert a 'ModuleProvidesU' to a 'ModuleProvides'
 669 convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides
 670 convertModuleProvidesU = traverse (traverse (traverse convertModuleU))
 671
 672 convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s)
 673 convertModuleRequires = convertModuleProvides
 674
 675 convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires
 676 convertModuleRequiresU = convertModuleProvidesU