[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / rename / RenameMonad4.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
3 %
4 \section[RenameMonad4]{The monad used by the fourth renamer pass}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module RenameMonad4 (
10         Rn4M(..),
11         initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
12         addErrRn4, failButContinueRn4, recoverQuietlyRn4,
13         pushSrcLocRn4,
14         getSrcLocRn4,
15         getSwitchCheckerRn4,
16         lookupValue, lookupValueEvenIfInvisible,
17         lookupClassOp, lookupFixityOp,
18         lookupTyCon, lookupTyConEvenIfInvisible,
19         lookupClass,
20         extendSS2, extendSS,
21         namesFromProtoNames,
22
23         TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
24         lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
25
26         -- for completeness
27         Module, Bag, RenamedPat(..), InPat, Maybe, Name, Error(..),
28         Pretty(..), PprStyle, PrettyRep, ProtoName, GlobalSwitch,
29         GlobalNameFun(..), GlobalNameFuns(..), UniqSet(..), UniqFM, SrcLoc,
30         Unique, SplitUniqSupply
31         IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
32     ) where
33
34 IMPORT_Trace            -- ToDo: rm (debugging)
35 import Pretty
36 import Outputable
37
38 import AbsSyn
39 import Bag
40 import CmdLineOpts      ( GlobalSwitch(..) )
41 import Errors           ( dupNamesErr, unknownNameErr, shadowedNameErr,
42                           badClassOpErr, Error(..)
43                         )
44 import FiniteMap        ( lookupFM, addToFM, addListToFM, emptyFM, FiniteMap )
45 import Maybes           ( Maybe(..), assocMaybe )
46 import Name             ( isTyConName, isClassName, isClassOpName,
47                           isUnboundName, invisibleName
48                         )
49 import NameTypes        ( mkShortName, ShortName )
50 import ProtoName        -- lots of stuff
51 import RenameAuxFuns    -- oh, why not ... all of it
52 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
53 import SplitUniq
54 import UniqSet
55 import Unique
56 import Util
57
58 infixr 9 `thenRn4`, `thenRn4_`
59 \end{code}
60
61 %************************************************************************
62 %*                                                                      *
63 \subsection[RenameMonad]{Plain @Rename@ monadery}
64 %*                                                                      *
65 %************************************************************************
66
67 \begin{code}
68 type ScopeStack = FiniteMap FAST_STRING Name
69
70 type Rn4M result
71   =  (GlobalSwitch -> Bool)
72   -> GlobalNameFuns
73   -> ScopeStack
74   -> Bag Error
75   -> SplitUniqSupply
76   -> SrcLoc
77   -> (result, Bag Error)
78
79 #ifdef __GLASGOW_HASKELL__
80 {-# INLINE andRn4 #-}
81 {-# INLINE thenRn4 #-}
82 {-# INLINE thenRn4_ #-}
83 {-# INLINE returnRn4 #-}
84 #endif
85
86 initRn4 :: (GlobalSwitch -> Bool)
87         -> GlobalNameFuns
88         -> Rn4M result
89         -> SplitUniqSupply
90         -> (result, Bag Error)
91
92 initRn4 sw_chkr gnfs renamer init_us
93   = renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
94
95 thenRn4  :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
96 thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
97 andRn4   :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
98
99 thenRn4 expr cont sw_chkr gnfs ss errs uniqs locn
100   = case (splitUniqSupply uniqs)                   of { (s1, s2) ->
101     case (expr      sw_chkr gnfs ss errs  s1 locn) of { (res1, errs1) ->
102     case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
103     (res2, errs2) }}}
104
105 thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn
106   = case (splitUniqSupply uniqs)              of { (s1, s2) ->
107     case (expr sw_chkr gnfs ss errs  s1 locn) of { (_,    errs1) ->
108     case (cont sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
109     (res2, errs2) }}}
110
111 andRn4 combiner m1 m2 sw_chkr gnfs ss errs us locn
112   = case (splitUniqSupply us)               of { (s1, s2) ->
113     case (m1 sw_chkr gnfs ss errs  s1 locn) of { (res1, errs1) ->
114     case (m2 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
115     (combiner res1 res2, errs2) }}}
116
117 returnRn4 :: a -> Rn4M a
118 returnRn4 result sw_chkr gnfs ss errs_so_far uniqs locn
119    = (result, errs_so_far)
120
121 failButContinueRn4 :: a -> Error -> Rn4M a
122 failButContinueRn4 res err sw_chkr gnfs ss errs_so_far uniqs locn
123   = (res, errs_so_far `snocBag` err)
124
125 addErrRn4 :: Error -> Rn4M ()
126 addErrRn4 err sw_chkr gnfs ss errs_so_far uniqs locn
127   = ((), errs_so_far `snocBag` err)
128 \end{code}
129
130 When we're looking at interface pragmas, we want to be able to recover
131 back to a ``I don't know anything pragmatic'' state if we encounter
132 some problem.  @recoverQuietlyRn4@ is given a ``use-this-instead'' value,
133 as well as the action to perform.  This code is intentionally very lazy,
134 returning a triple immediately, no matter what.
135 \begin{code}
136 recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
137
138 recoverQuietlyRn4 use_this_if_err action sw_chkr gnfs ss errs_so_far uniqs locn
139   = let
140         (result, errs_out)
141           = case (action sw_chkr gnfs ss emptyBag{-leav out errs-} uniqs locn) of
142               (result1, errs1) ->
143                 if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
144                     (result1, errs_so_far)
145                 else -- give up; return *incoming* UniqueSupply...
146                     (use_this_if_err,
147                      if sw_chkr ShowPragmaNameErrs
148                      then errs_so_far `unionBags` errs1
149                      else errs_so_far) -- toss errs, otherwise
150     in
151     (result, errs_out)
152 \end{code}
153
154 \begin{code}
155 mapRn4 :: (a -> Rn4M b) -> [a] -> Rn4M [b]
156
157 mapRn4 f []     = returnRn4 []
158 mapRn4 f (x:xs)
159   = f x         `thenRn4` \ r ->
160     mapRn4 f xs `thenRn4` \ rs ->
161     returnRn4 (r:rs)
162
163 mapAndUnzipRn4  :: (a -> Rn4M (b,c))   -> [a] -> Rn4M ([b],[c])
164
165 mapAndUnzipRn4 f [] = returnRn4 ([],[])
166 mapAndUnzipRn4 f (x:xs)
167   = f x                 `thenRn4` \ (r1,  r2)  ->
168     mapAndUnzipRn4 f xs `thenRn4` \ (rs1, rs2) ->
169     returnRn4 (r1:rs1, r2:rs2)
170 \end{code}
171
172 \begin{code}
173 pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
174 pushSrcLocRn4 locn exp sw_chkr gnfs ss errs_so_far uniq_supply old_locn
175   = exp sw_chkr gnfs ss errs_so_far uniq_supply locn
176
177 getSrcLocRn4 :: Rn4M SrcLoc
178
179 getSrcLocRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
180   = returnRn4 locn sw_chkr gnfs ss errs_so_far uniq_supply locn
181
182 getSwitchCheckerRn4 :: Rn4M (GlobalSwitch -> Bool)
183
184 getSwitchCheckerRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
185   = returnRn4 sw_chkr sw_chkr gnfs ss errs_so_far uniq_supply locn
186 \end{code}
187
188 \begin{code}
189 getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
190 getNextUniquesFromRn4 n sw_chkr gnfs ss errs_so_far us locn
191   = case (getSUniques n us) of { next_uniques ->
192     (next_uniques, errs_so_far) }
193 \end{code}
194
195 *********************************************************
196 *                                                       *
197 \subsection{Making new names}
198 *                                                       *
199 *********************************************************
200
201 @namesFromProtoNames@ takes a bunch of protonames, which are defined
202 together in a group (eg a pattern or set of bindings), checks they
203 are distinct, and creates new full names for them.
204
205 \begin{code}
206 namesFromProtoNames :: String           -- Documentation string
207                     -> [(ProtoName, SrcLoc)]
208                     -> Rn4M [Name]      
209
210 namesFromProtoNames kind pnames_w_src_loc sw_chkr gnfs ss errs_so_far us locn
211   = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
212     mkNewNames goodies
213     ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
214   where
215     (goodies, dups) = removeDups cmp pnames_w_src_loc
216         -- We want to compare their local names rather than their 
217         -- full protonames.  It probably doesn't matter here, but it
218         -- does in Rename3.lhs!
219     cmp (a, _) (b, _) = cmpByLocalName a b
220 \end{code}
221
222 @mkNewNames@ assumes the names are unique.
223
224 \begin{code}
225 mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]      
226 mkNewNames pnames_w_locs
227   = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
228     returnRn4 (zipWith new_short_name uniqs pnames_w_locs)
229   where
230     new_short_name uniq (Unk str, srcloc)   -- gotta be an Unk...
231       = Short uniq (mkShortName str srcloc)
232 \end{code}
233
234
235 *********************************************************
236 *                                                       *
237 \subsection{Local scope extension and lookup}
238 *                                                       *
239 *********************************************************
240
241 If the input name is an @Imp@, @lookupValue@ looks it up in the GNF.
242 If it is an @Unk@, it looks it up first in the local environment
243 (scope stack), and if it isn't found there, then in the value GNF.  If
244 it isn't found at all, @lookupValue@ adds an error message, and
245 returns an @Unbound@ name.
246
247 \begin{code}
248 unboundName :: ProtoName -> Name
249 unboundName pn
250    = Unbound (grab_string pn)
251    where
252      grab_string (Unk s)       = s
253      grab_string (Imp _ _ _ s) = s
254 \end{code}
255
256 @lookupValue@ looks up a non-invisible value;
257 @lookupValueEvenIfInvisible@ gives a successful lookup even if the
258 value is not visible to the user (e.g., came out of a pragma).
259 @lookup_val@ is the help function to do the work.
260
261 \begin{code}
262 lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
263   = (lookup_val v       `thenRn4` \ name ->
264     if invisibleName name
265     then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
266     else returnRn4 name
267     ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
268
269 lookupValueEvenIfInvisible v = lookup_val v
270
271 lookup_val :: ProtoName -> Rn4M Name
272
273 lookup_val pname@(Unk v) sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
274   = case (lookupFM ss v) of
275       Just name -> returnRn4 name sw_chkr gnfs ss a b locn
276       Nothing   -> case (v_gnf pname) of
277                      Just name  -> returnRn4 name sw_chkr gnfs ss a b locn
278                      Nothing    -> failButContinueRn4 (unboundName pname)
279                                            (unknownNameErr "value" pname locn)
280                                            sw_chkr gnfs ss a b locn
281
282 -- If it ain't an Unk it must be in the global name fun; that includes
283 -- prelude things.
284 lookup_val pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
285   = case (v_gnf pname) of
286         Just name  -> returnRn4 name sw_chkr gnfs ss a b locn
287         Nothing    -> failButContinueRn4 (unboundName pname)
288                               (unknownNameErr "value" pname locn)
289                               sw_chkr gnfs ss a b locn
290 \end{code}
291
292 Looking up the operators in a fixity decl is done differently.  We
293 want to simply drop any fixity decls which refer to operators which
294 aren't in scope.  Unfortunately, such fixity decls {\em will} appear
295 because the parser collects *all* the fixity decls from {\em all} the
296 imported interfaces (regardless of selective import), and dumps them
297 together as the module fixity decls.  This is really a bug.  In
298 particular:
299 \begin{itemize}
300 \item
301 We won't complain about fixity decls for operators which aren't
302 declared.
303 \item
304 We won't attach the right fixity to something which has been renamed.
305 \end{itemize}
306
307 We're not going to export Prelude-related fixities (ToDo: correctly),
308 so we nuke those, too.
309
310 \begin{code}
311 lookupFixityOp (Prel _) sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing       sw_chkr gnfs
312 lookupFixityOp pname    sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) sw_chkr gnfs
313 \end{code}
314
315 \begin{code}
316 lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
317 -- The global name funs handle Prel things
318
319 lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
320   = (lookup_tycon tc `thenRn4` \ name ->
321     if invisibleName name
322     then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
323     else returnRn4 name
324     ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
325
326 lookupTyConEvenIfInvisible tc = lookup_tycon tc
327
328 lookup_tycon (Prel name) sw_chkr gnfs ss a b locn = returnRn4 name sw_chkr gnfs ss a b locn
329
330 lookup_tycon pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
331   = case (tc_gnf pname) of
332      Just name | isTyConName name -> returnRn4 name sw_chkr gnfs ss a b locn
333      _   -> failButContinueRn4 (unboundName pname)
334                     (unknownNameErr "type constructor" pname locn)
335                     sw_chkr gnfs ss a b locn
336 \end{code}
337
338 \begin{code}
339 lookupClass :: ProtoName -> Rn4M Name
340
341 lookupClass pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
342   = case (tc_gnf pname) of
343      Just name | isClassName name -> returnRn4 name sw_chkr gnfs ss a b locn
344      _   -> failButContinueRn4 (unboundName pname)
345                     (unknownNameErr "class" pname locn)
346                     sw_chkr gnfs ss a b locn
347 \end{code}
348
349 @lookupClassOp@ is used when looking up the lhs identifiers in a class
350 or instance decl.  It checks that the name it finds really is a class
351 op, and that its class matches that of the class or instance decl
352 being looked at.
353
354 \begin{code}
355 lookupClassOp :: Name -> ProtoName -> Rn4M Name
356
357 lookupClassOp class_name pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
358   = case v_gnf pname of
359          Just op_name |  isClassOpName class_name op_name
360                       || isUnboundName class_name -- avoid spurious errors
361                  -> returnRn4 op_name sw_chkr gnfs ss a b locn
362
363          other   -> failButContinueRn4 (unboundName pname)
364                             (badClassOpErr class_name pname locn)
365                             sw_chkr gnfs ss a b locn
366 \end{code}
367
368 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
369 free vars from the result.
370
371 \begin{code}
372 extendSS :: [Name]                              -- Newly bound names
373          -> Rn4M a
374          -> Rn4M a
375
376 extendSS binders expr sw_chkr gnfs ss errs us locn
377   = case (extend binders ss sw_chkr gnfs ss errs us locn) of { (new_ss, new_errs) ->
378     expr sw_chkr gnfs new_ss new_errs us locn }
379   where
380     extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
381
382     extend names ss
383       = if (sw_chkr NameShadowingNotOK) then
384             hard_way names ss
385         else -- ignore shadowing; blast 'em in
386             returnRn4 (
387                 addListToFM ss [ (getOccurrenceName x, n) | n@(Short _ x) <- names]
388             )
389
390     hard_way [] ss = returnRn4 ss
391     hard_way (name@(Short _ sname):names) ss
392       = let
393             str = getOccurrenceName sname
394         in
395         (case (lookupFM ss str) of
396            Nothing -> returnRn4 (addToFM ss str name)
397            Just  _ -> failButContinueRn4 ss (shadowedNameErr name locn)
398
399         )       `thenRn4` \ new_ss ->
400         hard_way names new_ss
401
402 extendSS2 :: [Name]                             -- Newly bound names
403          -> Rn4M (a, UniqSet Name)
404          -> Rn4M (a, UniqSet Name)
405
406 extendSS2 binders expr sw_chkr gnfs ss errs_so_far us locn
407   = case (extendSS binders expr sw_chkr gnfs ss errs_so_far us locn) of
408      ((e2, freevars), errs)
409        -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
410            errs)
411 \end{code}
412
413 The free var set returned by @(extendSS binders m)@ is that returned
414 by @m@, {\em minus} binders.
415
416 *********************************************************
417 *                                                       *
418 \subsection{mkTyVarNamesEnv}
419 *                                                       *
420 *********************************************************
421
422 \begin{code}
423 type TyVarNamesEnv = [(ProtoName, Name)]
424
425 nullTyVarNamesEnv :: TyVarNamesEnv
426 nullTyVarNamesEnv = []
427
428 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
429 catTyVarNamesEnvs e1 e2 = e1 ++ e2
430
431 domTyVarNamesEnv :: TyVarNamesEnv -> [ProtoName]
432 domTyVarNamesEnv env = map fst env
433 \end{code}
434
435 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
436
437 \begin{code}
438 mkTyVarNamesEnv
439         :: SrcLoc
440         -> [ProtoName]                  -- The type variables
441         -> Rn4M (TyVarNamesEnv,[Name])  -- Environment and renamed tyvars
442
443 mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
444   = (namesFromProtoNames "type variable"
445          (tyvars `zip` repeat src_loc)  `thenRn4`  \ tyvars2 ->
446
447          -- tyvars2 may not be in the same order as tyvars, so we need some
448          -- jiggery pokery to build the right tyvar env, and return the
449          -- renamed tyvars in the original order.
450     let tv_string_name_pairs    = extend tyvars2 []
451         tv_env                  = map (lookup tv_string_name_pairs) tyvars
452         tyvars2_in_orig_order   = map snd tv_env
453     in
454     returnRn4  (tv_env, tyvars2_in_orig_order)
455     ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
456   where
457     extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
458     extend [] ss = ss
459     extend (name@(Short _ sname):names) ss
460       = (getOccurrenceName sname, name) : extend names ss
461
462     lookup :: [(FAST_STRING, Name)] -> ProtoName -> (ProtoName, Name)
463     lookup pairs tyvar_pn
464       = (tyvar_pn, assoc "mkTyVarNamesEnv" pairs (getOccurrenceName tyvar_pn))
465 \end{code}
466
467 \begin{code}
468 lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
469 lookupTyVarName env pname {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
470   = (case (assoc_maybe env pname) of
471      Just name -> returnRn4 name
472      Nothing   -> getSrcLocRn4  `thenRn4` \ loc ->
473                   failButContinueRn4 (unboundName pname)
474                           (unknownNameErr "type variable" pname loc)
475     ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
476   where
477     assoc_maybe [] _ = Nothing
478     assoc_maybe ((tv,xxx) : tvs) key
479       = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key
480 \end{code}