The Backpack patch.
[ghc.git] / compiler / backpack / NameShape.hs
1 {-# LANGUAGE CPP #-}
2
3 module NameShape(
4 NameShape(..),
5 emptyNameShape,
6 mkNameShape,
7 extendNameShape,
8 nameShapeExports,
9 substNameShape,
10 ) where
11
12 #include "HsVersions.h"
13
14 import Outputable
15 import HscTypes
16 import Module
17 import UniqFM
18 import Avail
19 import FieldLabel
20
21 import Name
22 import NameEnv
23 import TcRnMonad
24 import Util
25 import ListSetOps
26 import IfaceEnv
27
28 import Control.Monad
29
30 -- Note [NameShape]
31 -- ~~~~~~~~~~~~~~~~
32 -- When we write a declaration in a signature, e.g., data T, we
33 -- ascribe to it a *name variable*, e.g., {m.T}. This
34 -- name variable may be substituted with an actual original
35 -- name when the signature is implemented (or even if we
36 -- merge the signature with one which reexports this entity
37 -- from another module).
38
39 -- When we instantiate a signature m with a module M,
40 -- we also need to substitute over names. To do so, we must
41 -- compute the *name substitution* induced by the *exports*
42 -- of the module in question. A NameShape represents
43 -- such a name substitution for a single module instantiation.
44 -- The "shape" in the name comes from the fact that the computation
45 -- of a name substitution is essentially the *shaping pass* from
46 -- Backpack'14, but in a far more restricted form.
47
48 -- The name substitution for an export list is easy to explain. If we are
49 -- filling the module variable <m>, given an export N of the form
50 -- M.n or {m'.n} (where n is an OccName), the induced name
51 -- substitution is from {m.n} to N. So, for example, if we have
52 -- A=impl:B, and the exports of impl:B are impl:B.f and
53 -- impl:C.g, then our name substitution is {A.f} to impl:B.f
54 -- and {A.g} to impl:C.g
55
56
57
58
59 -- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes
60 -- needs to refer to NameShape, and having TcRnTypes import
61 -- NameShape (even by SOURCE) would cause a large number of
62 -- modules to be pulled into the DynFlags cycle.
63 {-
64 data NameShape = NameShape {
65 ns_mod_name :: ModuleName,
66 ns_exports :: [AvailInfo],
67 ns_map :: OccEnv Name
68 }
69 -}
70
71 -- NB: substitution functions need 'HscEnv' since they need the name cache
72 -- to allocate new names if we change the 'Module' of a 'Name'
73
74 -- | Create an empty 'NameShape' (i.e., the renaming that
75 -- would occur with an implementing module with no exports)
76 -- for a specific hole @mod_name@.
77 emptyNameShape :: ModuleName -> NameShape
78 emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
79
80 -- | Create a 'NameShape' corresponding to an implementing
81 -- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
82 mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
83 mkNameShape mod_name as =
84 NameShape mod_name as $ mkOccEnv $ do
85 a <- as
86 n <- availName a : availNames a
87 return (occName n, n)
88
89 -- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
90 -- with Backpack style mix-in linking. This is used solely when merging
91 -- signatures together: we successively merge the exports of each
92 -- signature until we have the final, full exports of the merged signature.
93 --
94 -- What makes this operation nontrivial is what we are supposed to do when
95 -- we want to merge in an export for M.T when we already have an existing
96 -- export {H.T}. What should happen in this case is that {H.T} should be
97 -- unified with @M.T@: we've determined a more *precise* identity for the
98 -- export at 'OccName' @T@.
99 --
100 -- Note that we don't do unrestricted unification: only name holes from
101 -- @ns_mod_name ns@ are flexible. This is because we have a much more
102 -- restricted notion of shaping than in Backpack'14: we do shaping
103 -- *as* we do type-checking. Thus, once we shape a signature, its
104 -- exports are *final* and we're not allowed to refine them further,
105 extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
106 extendNameShape hsc_env ns as =
107 case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
108 Left err -> return (Left err)
109 Right nsubst -> do
110 as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
111 as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
112 let new_avails = mergeAvails as1 as2
113 return . Right $ ns {
114 ns_exports = new_avails,
115 -- TODO: stop repeatedly rebuilding the OccEnv
116 ns_map = mkOccEnv $ do
117 a <- new_avails
118 n <- availName a : availNames a
119 return (occName n, n)
120 }
121
122 -- | The export list associated with this 'NameShape' (i.e., what
123 -- the exports of an implementing module which induces this 'NameShape'
124 -- would be.)
125 nameShapeExports :: NameShape -> [AvailInfo]
126 nameShapeExports = ns_exports
127
128 -- | Given a 'Name', substitute it according to the 'NameShape' implied
129 -- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
130 -- exports @M.T@.
131 substNameShape :: NameShape -> Name -> Name
132 substNameShape ns n | nameModule n == ns_module ns
133 , Just n' <- lookupOccEnv (ns_map ns) (occName n)
134 = n'
135 | otherwise
136 = n
137
138 -- | The 'Module' of any 'Name's a 'NameShape' has action over.
139 ns_module :: NameShape -> Module
140 ns_module = mkHoleModule . ns_mod_name
141
142 {-
143 ************************************************************************
144 * *
145 Name substitutions
146 * *
147 ************************************************************************
148 -}
149
150 -- | Substitution on @{A.T}@. We enforce the invariant that the
151 -- 'nameModule' of keys of this map have 'moduleUnitId' @hole@
152 -- (meaning that if we have a hole substitution, the keys of the map
153 -- are never affected.) Alternately, this is ismorphic to
154 -- @Map ('ModuleName', 'OccName') 'Name'@.
155 type ShNameSubst = NameEnv Name
156
157 -- NB: In this module, we actually only ever construct 'ShNameSubst'
158 -- at a single 'ModuleName'. But 'ShNameSubst' is more convenient to
159 -- work with.
160
161 -- | Substitute names in a 'Name'.
162 substName :: ShNameSubst -> Name -> Name
163 substName env n | Just n' <- lookupNameEnv env n = n'
164 | otherwise = n
165
166 -- | Substitute names in an 'AvailInfo'. This has special behavior
167 -- for type constructors, where it is sufficient to substitute the 'availName'
168 -- to induce a substitution on 'availNames'.
169 substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
170 substNameAvailInfo _ env (Avail p n) = return (Avail p (substName env n))
171 substNameAvailInfo hsc_env env (AvailTC n ns fs) =
172 let mb_mod = fmap nameModule (lookupNameEnv env n)
173 in AvailTC (substName env n)
174 <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
175 <*> mapM (setNameFieldSelector hsc_env mb_mod) fs
176
177 -- | Set the 'Module' of a 'FieldSelector'
178 setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
179 setNameFieldSelector _ Nothing f = return f
180 setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do
181 sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
182 return (FieldLabel l b sel')
183
184 {-
185 ************************************************************************
186 * *
187 AvailInfo merging
188 * *
189 ************************************************************************
190 -}
191
192 -- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
193 -- already been unified ('uAvailInfos').
194 mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
195 mergeAvails as1 as2 =
196 let mkNE as = mkNameEnv [(availName a, a) | a <- as]
197 in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))
198
199 -- | Join two 'AvailInfo's together.
200 plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
201 plusAvail a1 a2
202 | debugIsOn && availName a1 /= availName a2
203 = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
204 plusAvail a1@(Avail {}) (Avail {}) = a1
205 plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2
206 plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1
207 plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
208 = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first
209 (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
210 (fs1 `unionLists` fs2)
211 (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
212 (fs1 `unionLists` fs2)
213 (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
214 (fs1 `unionLists` fs2)
215 (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
216 (fs1 `unionLists` fs2)
217 plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
218 = AvailTC n1 ss1 (fs1 `unionLists` fs2)
219 plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2)
220 = AvailTC n1 ss2 (fs1 `unionLists` fs2)
221 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
222
223 {-
224 ************************************************************************
225 * *
226 AvailInfo unification
227 * *
228 ************************************************************************
229 -}
230
231 -- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
232 -- with only name holes from @flexi@ unifiable (all other name holes rigid.)
233 uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
234 uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
235 let mkOE as = listToUFM $ do a <- as
236 n <- availNames a
237 return (nameOccName n, a)
238 in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
239 (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
240 -- Edward: I have to say, this is pretty clever.
241
242 -- | Unify two 'AvailInfo's, given an existing substitution @subst@,
243 -- with only name holes from @flexi@ unifiable (all other name holes rigid.)
244 uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
245 -> Either SDoc ShNameSubst
246 uAvailInfo flexi subst (Avail _ n1) (Avail _ n2) = uName flexi subst n1 n2
247 uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2
248 uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
249 <+> ppr a1 <+> text "with" <+> ppr a2
250 <+> parens (text "one is a type, the other is a plain identifier")
251
252 -- | Unify two 'Name's, given an existing substitution @subst@,
253 -- with only name holes from @flexi@ unifiable (all other name holes rigid.)
254 uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
255 uName flexi subst n1 n2
256 | n1 == n2 = Right subst
257 | isFlexi n1 = uHoleName flexi subst n1 n2
258 | isFlexi n2 = uHoleName flexi subst n2 n1
259 | otherwise = Left (text "While merging export lists, could not unify"
260 <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
261 where
262 isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
263 extra | isHoleName n1 || isHoleName n2
264 = text "Neither name variable originates from the current signature."
265 | otherwise
266 = empty
267
268 -- | Unify a name @h@ which 'isHoleName' with another name, given an existing
269 -- substitution @subst@, with only name holes from @flexi@ unifiable (all
270 -- other name holes rigid.)
271 uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
272 -> Either SDoc ShNameSubst
273 uHoleName flexi subst h n =
274 ASSERT( isHoleName h )
275 case lookupNameEnv subst h of
276 Just n' -> uName flexi subst n' n
277 -- Do a quick check if the other name is substituted.
278 Nothing | Just n' <- lookupNameEnv subst n ->
279 ASSERT( isHoleName n ) uName flexi subst h n'
280 | otherwise ->
281 Right (extendNameEnv subst h n)