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