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