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