Cabal/src/Distribution/Backpack/MixLink.hs

   1 {-# LANGUAGE NondecreasingIndentation #-}
   2
   3 -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
   4 module Distribution.Backpack.MixLink
   5   ( mixLink
   6   ) where
   7
   8 import Distribution.Compat.Prelude hiding (mod)
   9 import Prelude ()
  10
  11 import Distribution.Backpack
  12 import Distribution.Backpack.FullUnitId
  13 import Distribution.Backpack.ModuleScope
  14 import Distribution.Backpack.UnifyM
  15
  16 import Distribution.ModuleName
  17 import Distribution.Pretty
  18 import Distribution.Types.ComponentId
  19 import qualified Distribution.Utils.UnionFind as UnionFind
  20
  21 import Control.Monad
  22 import qualified Data.Foldable as F
  23 import qualified Data.Map as Map
  24 import Text.PrettyPrint
  25
  26 -----------------------------------------------------------------------
  27 -- Linking
  28
  29 -- | Given to scopes of provisions and requirements, link them together.
  30 mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
  31 mixLink scopes = do
  32   let provs = Map.unionsWith (++) (map fst scopes)
  33       -- Invariant: any identically named holes refer to same mutable cell
  34       reqs = Map.unionsWith (++) (map snd scopes)
  35       filled = Map.intersectionWithKey linkProvision provs reqs
  36   F.sequenceA_ filled
  37   let remaining = Map.difference reqs filled
  38   return (provs, remaining)
  39
  40 -- | Link a list of possibly provided modules to a single
  41 -- requirement.  This applies a side-condition that all
  42 -- of the provided modules at the same name are *actually*
  43 -- the same module.
  44 linkProvision
  45   :: ModuleName
  46   -> [ModuleWithSourceU s] -- provs
  47   -> [ModuleWithSourceU s] -- reqs
  48   -> UnifyM s [ModuleWithSourceU s]
  49 linkProvision mod_name ret@(prov : provs) (req : reqs) = do
  50   -- TODO: coalesce all the non-unifying modules together
  51   forM_ provs $ \prov' -> do
  52     -- Careful: read it out BEFORE unifying, because the
  53     -- unification algorithm preemptively unifies modules
  54     mod <- convertModuleU (unWithSource prov)
  55     mod' <- convertModuleU (unWithSource prov')
  56     r <- unify prov prov'
  57     case r of
  58       Just () -> return ()
  59       Nothing -> do
  60         addErr $
  61           text "Ambiguous module"
  62             <+> quotes (pretty mod_name)
  63             $$ text "It could refer to"
  64             <+> ( text "  "
  65                     <+> (quotes (pretty mod) $$ in_scope_by (getSource prov))
  66                     $$ text "or"
  67                     <+> (quotes (pretty mod') $$ in_scope_by (getSource prov'))
  68                 )
  69             $$ link_doc
  70   mod <- convertModuleU (unWithSource prov)
  71   req_mod <- convertModuleU (unWithSource req)
  72   self_cid <- fmap unify_self_cid getUnifEnv
  73   case mod of
  74     OpenModule (IndefFullUnitId cid _) _
  75       | cid == self_cid ->
  76           addErr $
  77             text "Cannot instantiate requirement"
  78               <+> quotes (pretty mod_name)
  79               <+> in_scope_by (getSource req)
  80               $$ text "with locally defined module"
  81               <+> in_scope_by (getSource prov)
  82               $$ text "as this would create a cyclic dependency, which GHC does not support."
  83               $$ text "Try moving this module to a separate library, e.g.,"
  84               $$ text "create a new stanza: library 'sublib'."
  85     _ -> return ()
  86   r <- unify prov req
  87   case r of
  88     Just () -> return ()
  89     Nothing -> do
  90       -- TODO: Record and report WHERE the bad constraint came from
  91       addErr $
  92         text "Could not instantiate requirement"
  93           <+> quotes (pretty mod_name)
  94           $$ nest
  95             4
  96             ( text "Expected:"
  97                 <+> pretty mod
  98                 $$ text "Actual:  "
  99                 <+> pretty req_mod
 100             )
 101           $$ parens
 102             ( text "This can occur if an exposed module of"
 103                 <+> text "a libraries shares a name with another module."
 104             )
 105           $$ link_doc
 106   return ret
 107   where
 108     unify s1 s2 =
 109       tryM $
 110         addErrContext short_link_doc $
 111           unifyModule (unWithSource s1) (unWithSource s2)
 112     in_scope_by s = text "brought into scope by" <+> dispModuleSource s
 113     short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name)
 114     link_doc = text "While filling requirements of" <+> reqs_doc
 115     reqs_doc
 116       | null reqs = dispModuleSource (getSource req)
 117       | otherwise =
 118           ( text "   "
 119               <+> dispModuleSource (getSource req)
 120               $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs]
 121           )
 122 linkProvision _ _ _ = error "linkProvision"
 123
 124 -----------------------------------------------------------------------
 125 -- The unification algorithm
 126
 127 -- This is based off of https://gist.github.com/amnn/559551517d020dbb6588
 128 -- which is a translation from Huet's thesis.
 129
 130 unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s ()
 131 unifyUnitId uid1_u uid2_u
 132   | uid1_u == uid2_u = return ()
 133   | otherwise = do
 134       xuid1 <- liftST $ UnionFind.find uid1_u
 135       xuid2 <- liftST $ UnionFind.find uid2_u
 136       case (xuid1, xuid2) of
 137         (UnitIdThunkU u1, UnitIdThunkU u2)
 138           | u1 == u2 -> return ()
 139           | otherwise ->
 140               failWith $
 141                 hang
 142                   (text "Couldn't match unit IDs:")
 143                   4
 144                   ( text "   "
 145                       <+> pretty u1
 146                       $$ text "and"
 147                       <+> pretty u2
 148                   )
 149         (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) ->
 150           unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u
 151         (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) ->
 152           unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u
 153         (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) ->
 154           unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
 155
 156 unifyThunkWith
 157   :: ComponentId
 158   -> Map ModuleName (ModuleU s)
 159   -> UnitIdU s
 160   -> DefUnitId
 161   -> UnitIdU s
 162   -> UnifyM s ()
 163 unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do
 164   db <- fmap unify_db getUnifEnv
 165   let FullUnitId cid2 insts2' = expandUnitId db uid2
 166   insts2 <- convertModuleSubst insts2'
 167   unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
 168
 169 unifyInner
 170   :: ComponentId
 171   -> Map ModuleName (ModuleU s)
 172   -> UnitIdU s
 173   -> ComponentId
 174   -> Map ModuleName (ModuleU s)
 175   -> UnitIdU s
 176   -> UnifyM s ()
 177 unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do
 178   when (cid1 /= cid2) $
 179     -- TODO: if we had a package identifier, could be an
 180     -- easier to understand error message.
 181     failWith $
 182       hang
 183         (text "Couldn't match component IDs:")
 184         4
 185         ( text "   "
 186             <+> pretty cid1
 187             $$ text "and"
 188             <+> pretty cid2
 189         )
 190   -- The KEY STEP which makes this a Huet-style unification
 191   -- algorithm.  (Also a payoff of using union-find.)
 192   -- We can build infinite unit IDs this way, which is necessary
 193   -- for support mutual recursion. NB: union keeps the SECOND
 194   -- descriptor, so we always arrange for a UnitIdThunkU to live
 195   -- there.
 196   liftST $ UnionFind.union uid1_u uid2_u
 197   F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2
 198
 199 -- | Imperatively unify two modules.
 200 unifyModule :: ModuleU s -> ModuleU s -> UnifyM s ()
 201 unifyModule mod1_u mod2_u
 202   | mod1_u == mod2_u = return ()
 203   | otherwise = do
 204       mod1 <- liftST $ UnionFind.find mod1_u
 205       mod2 <- liftST $ UnionFind.find mod2_u
 206       case (mod1, mod2) of
 207         (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u
 208         (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u
 209         (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do
 210           when (mod_name1 /= mod_name2) $
 211             failWith $
 212               hang (text "Cannot match module names") 4 $
 213                 text "   "
 214                   <+> pretty mod_name1
 215                   $$ text "and"
 216                   <+> pretty mod_name2
 217           -- NB: this is not actually necessary (because we'll
 218           -- detect loops eventually in 'unifyUnitId'), but it
 219           -- seems harmless enough
 220           liftST $ UnionFind.union mod1_u mod2_u
 221           unifyUnitId uid1 uid2