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