2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
8 rnSrcDecls, checkModDeprec,
9 rnTyClDecl, rnIfaceRuleDecl, rnInstDecl,
10 rnBinds, rnBindsAndThen, rnStats,
13 #include "HsVersions.h"
16 import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
17 import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
18 RdrNameDeprecation, RdrNameFixitySig,
20 extractGenericPatTyVars
24 import RnExpr ( rnExpr )
25 import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
27 import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
28 rnMonoBindsAndThen, renameSigs, checkSigs )
29 import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
30 newLocalsRn, lookupGlobalOccRn,
31 bindLocalsFVRn, bindPatSigTyVars,
32 bindTyVarsRn, extendTyVarEnvFVRn,
33 bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
34 checkDupOrQualNames, checkDupNames, mapFvRn,
35 lookupTopSrcBndr_maybe, lookupTopSrcBndr,
36 dataTcOccs, newIPName, unknownNameErr
40 import BasicTypes ( FixitySig(..) )
41 import HscTypes ( ExternalPackageState(..), FixityEnv,
42 Deprecations(..), plusDeprecs )
43 import Module ( moduleEnvElts )
44 import Class ( FunDep, DefMeth (..) )
45 import TyCon ( DataConDetails(..), visibleDataCons )
49 import ErrUtils ( dumpIfSet )
50 import PrelNames ( newStablePtrName, bindIOName, returnIOName )
51 import List ( partition )
52 import Bag ( bagToList )
54 import SrcLoc ( SrcLoc )
55 import CmdLineOpts ( DynFlag(..) )
56 -- Warn of unused for-all'd tyvars
57 import Maybes ( maybeToBool, seqMaybe )
58 import Maybe ( maybe, catMaybes, isNothing )
61 @rnSourceDecl@ `renames' declarations.
62 It simultaneously performs dependency analysis and precedence parsing.
63 It also does the following error checks:
66 Checks that tyvars are used properly. This includes checking
67 for undefined tyvars, and tyvars in contexts that are ambiguous.
68 (Some of this checking has now been moved to module @TcMonoType@,
69 since we don't have functional dependency information at this point.)
71 Checks that all variable occurences are defined.
73 Checks the @(..)@ etc constraints in the export list.
78 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars)
80 rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _,
81 hs_tyclds = tycl_decls,
82 hs_instds = inst_decls,
84 hs_depds = deprec_decls,
85 hs_fords = foreign_decls,
86 hs_defds = default_decls,
87 hs_ruleds = rule_decls,
88 hs_coreds = core_decls })
90 = do { -- Deal with deprecations (returns only the extra deprecations)
91 deprecs <- rnSrcDeprecDecls deprec_decls ;
92 updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
95 -- Deal with top-level fixity decls
96 -- (returns the total new fixity env)
97 fix_env <- rnSrcFixityDecls fix_decls ;
98 updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
101 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
103 -- Rename other declarations
104 (rn_val_decls, src_fvs1) <- rnTopMonoBinds binds sigs ;
105 (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ;
106 (rn_tycl_decls, src_fvs3) <- mapFvRn rnSrcTyClDecl tycl_decls ;
107 (rn_rule_decls, src_fvs4) <- mapFvRn rnHsRuleDecl rule_decls ;
108 (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ;
109 (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ;
110 (rn_core_decls, src_fvs7) <- mapFvRn rnCoreDecl core_decls ;
113 rn_group = HsGroup { hs_valds = rn_val_decls,
114 hs_tyclds = rn_tycl_decls,
115 hs_instds = rn_inst_decls,
118 hs_fords = rn_foreign_decls,
119 hs_defds = rn_default_decls,
120 hs_ruleds = rn_rule_decls,
121 hs_coreds = rn_core_decls } ;
122 src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
123 src_fvs5, src_fvs6, src_fvs7] } ;
125 traceRn (text "rnSrcDecls" <+> ppr (nameSetToList src_fvs)) ;
126 tcg_env <- getGblEnv ;
127 return (tcg_env, rn_group, src_fvs)
132 %*********************************************************
134 Source-code fixity declarations
136 %*********************************************************
139 rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv
140 rnSrcFixityDecls fix_decls
141 = getGblEnv `thenM` \ gbl_env ->
142 foldlM rnFixityDecl (tcg_fix_env gbl_env)
143 fix_decls `thenM` \ fix_env ->
144 traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
147 rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
148 rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
149 = -- GHC extension: look up both the tycon and data con
150 -- for con-like things
151 -- If neither are in scope, report an error; otherwise
152 -- add both to the fixity env
153 mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns ->
154 case catMaybes maybe_ns of
155 [] -> addSrcLoc loc $
156 addErr (unknownNameErr rdr_name) `thenM_`
158 ns -> foldlM add fix_env ns
161 = case lookupNameEnv fix_env name of
162 Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_`
164 Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc))
166 dupFixityDecl rdr_name loc1 loc2
167 = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
168 ptext SLIT("at ") <+> ppr loc1,
169 ptext SLIT("and") <+> ppr loc2]
173 %*********************************************************
175 Source-code deprecations declarations
177 %*********************************************************
179 For deprecations, all we do is check that the names are in scope.
180 It's only imported deprecations, dealt with in RnIfaces, that we
181 gather them together.
184 rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations
188 rnSrcDeprecDecls decls
189 = mappM rn_deprec decls `thenM` \ pairs ->
190 returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
192 rn_deprec (Deprecation rdr_name txt loc)
194 lookupTopSrcBndr rdr_name `thenM` \ name ->
195 returnM (Just (name, (name,txt)))
197 checkModDeprec :: Maybe DeprecTxt -> Deprecations
198 -- Check for a module deprecation; done once at top level
199 checkModDeprec Nothing = NoDeprecs
200 checkModdeprec (Just txt) = DeprecAll txt
203 = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
207 %*********************************************************
209 \subsection{Source code declarations}
211 %*********************************************************
214 rnSrcTyClDecl tycl_decl
215 = rnTyClDecl tycl_decl `thenM` \ new_decl ->
216 finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) ->
217 returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl')
220 = rnInstDecl inst `thenM` \ new_inst ->
221 finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) ->
222 returnM (new_inst', fvs `plusFV` instDeclFVs new_inst')
224 rnDefaultDecl (DefaultDecl tys src_loc)
225 = addSrcLoc src_loc $
226 mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
227 returnM (DefaultDecl tys' src_loc, fvs)
229 doc_str = text "In a `default' declaration"
232 rnCoreDecl (CoreDecl name ty rhs loc)
234 lookupTopBndrRn name `thenM` \ name' ->
235 rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) ->
236 rnCoreExpr rhs `thenM` \ rhs' ->
237 returnM (CoreDecl name' ty' rhs' loc,
238 ty_fvs `plusFV` ufExprFVs rhs')
240 doc_str = text "In the Core declaration for" <+> quotes (ppr name)
243 %*********************************************************
247 %*********************************************************
249 These chaps are here, rather than in TcBinds, so that there
250 is just one hi-boot file (for RnSource). rnSrcDecls is part
251 of the loop too, and it must be defined in this module.
254 rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
255 rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
256 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
257 -- The parser doesn't produce other forms
259 rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
260 -- This version assumes that the binders are already in scope
261 -- It's used only in 'mdo'
262 rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
263 rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
264 rnBinds b@(IPBinds bind _) = addErr (badIpBinds b) `thenM_`
265 returnM (EmptyBinds, emptyFVs)
267 rnBindsAndThen :: RdrNameHsBinds
268 -> (RenamedHsBinds -> RnM (result, FreeVars))
269 -> RnM (result, FreeVars)
270 -- This version (a) assumes that the binding vars are not already in scope
271 -- (b) removes the binders from the free vars of the thing inside
272 -- The parser doesn't produce ThenBinds
273 rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds
274 rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside
275 rnBindsAndThen (IPBinds binds is_with) thing_inside
276 = warnIf is_with withWarning `thenM_`
277 rnIPBinds binds `thenM` \ (binds',fv_binds) ->
278 thing_inside (IPBinds binds' is_with) `thenM` \ (thing, fvs_thing) ->
279 returnM (thing, fvs_thing `plusFV` fv_binds)
283 %************************************************************************
285 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
287 %************************************************************************
290 rnIPBinds [] = returnM ([], emptyFVs)
291 rnIPBinds ((n, expr) : binds)
292 = newIPName n `thenM` \ name ->
293 rnExpr expr `thenM` \ (expr',fvExpr) ->
294 rnIPBinds binds `thenM` \ (binds',fvBinds) ->
295 returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
300 %*********************************************************
302 \subsection{Foreign declarations}
304 %*********************************************************
307 rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
308 = addSrcLoc src_loc $
309 lookupTopBndrRn name `thenM` \ name' ->
310 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
311 returnM (ForeignImport name' ty' spec isDeprec src_loc,
312 fvs `plusFV` extras spec)
314 extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
315 bindIOName, returnIOName]
318 rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
319 = addSrcLoc src_loc $
320 lookupOccRn name `thenM` \ name' ->
321 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
322 returnM (ForeignExport name' ty' spec isDeprec src_loc,
323 mkFVs [name', bindIOName, returnIOName] `plusFV` fvs )
324 -- NB: a foreign export is an *occurrence site* for name, so
325 -- we add it to the free-variable list. It might, for example,
326 -- be imported from another module
328 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
332 %*********************************************************
334 \subsection{Instance declarations}
336 %*********************************************************
339 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
340 -- Used for both source and interface file decls
341 = addSrcLoc src_loc $
342 rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
344 (case maybe_dfun_rdr_name of
345 Nothing -> returnM Nothing
346 Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name ->
347 returnM (Just dfun_name)
348 ) `thenM` \ maybe_dfun_name ->
350 -- The typechecker checks that all the bindings are for the right class.
351 returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
353 -- Compare finishSourceTyClDecl
354 finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
355 (InstDecl inst_ty _ _ maybe_dfun_name src_loc)
356 -- Used for both source decls only
357 = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
359 meth_doc = text "In the bindings in an instance declaration"
360 meth_names = collectLocatedMonoBinders mbinds
361 (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
362 -- (Slightly strangely) the forall-d tyvars scope over
363 -- the method bindings too
366 -- Rename the bindings
367 -- NB meth_names can be qualified!
368 checkDupNames meth_doc meth_names `thenM_`
369 extendTyVarEnvForMethodBinds inst_tyvars (
370 rnMethodBinds cls [] mbinds
371 ) `thenM` \ (mbinds', meth_fvs) ->
373 binders = collectMonoBinders mbinds'
375 -- Rename the prags and signatures.
376 -- Note that the type variables are not in scope here,
377 -- so that instance Eq a => Eq (T a) where
378 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
381 -- But the (unqualified) method names are in scope
382 bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' ->
383 checkSigs okInstDclSig (mkNameSet binders) uprags' `thenM_`
385 returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
386 meth_fvs `plusFV` hsSigsFVs uprags')
389 %*********************************************************
393 %*********************************************************
396 rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
397 = addSrcLoc src_loc $
398 lookupOccRn fn `thenM` \ fn' ->
399 rnCoreBndrs vars $ \ vars' ->
400 mappM rnCoreExpr args `thenM` \ args' ->
401 rnCoreExpr rhs `thenM` \ rhs' ->
402 returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
404 rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way
405 = lookupOccRn fn `thenM` \ fn' ->
406 returnM (IfaceRuleOut fn' rule)
408 rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
409 = addSrcLoc src_loc $
410 bindPatSigTyVars (collectRuleBndrSigTys vars) $
412 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
413 mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
415 rnExpr lhs `thenM` \ (lhs', fv_lhs) ->
416 rnExpr rhs `thenM` \ (rhs', fv_rhs) ->
418 mb_bad = validRuleLhs ids lhs'
420 checkErr (isNothing mb_bad)
421 (badRuleLhsErr rule_name lhs' mb_bad) `thenM_`
423 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
425 mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
426 returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
427 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
429 doc = text "In the transformation rule" <+> ftext rule_name
431 get_var (RuleBndr v) = v
432 get_var (RuleBndrSig v _) = v
434 rn_var (RuleBndr v, id) = returnM (RuleBndr id, emptyFVs)
435 rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
436 returnM (RuleBndrSig id t', fvs)
439 Check the shape of a transformation rule LHS. Currently
440 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
441 not one of the @forall@'d variables. We also restrict the form of the LHS so
442 that it may be plausibly matched. Basically you only get to write ordinary
443 applications. (E.g. a case expression is not allowed: too elaborate.)
445 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
448 validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr
450 -- Just e => Not ok, and e is the offending expression
451 validRuleLhs foralls lhs
454 check (OpApp e1 op _ e2) = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2
455 check (HsApp e1 e2) = check e1 `seqMaybe` check_e e2
456 check (HsVar v) | v `notElem` foralls = Nothing
457 check other = Just other -- Failure
459 check_e (HsVar v) = Nothing
460 check_e (HsPar e) = check_e e
461 check_e (HsLit e) = Nothing
462 check_e (HsOverLit e) = Nothing
464 check_e (OpApp e1 op _ e2) = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2
465 check_e (HsApp e1 e2) = check_e e1 `seqMaybe` check_e e2
466 check_e (NegApp e _) = check_e e
467 check_e (ExplicitList _ es) = check_es es
468 check_e (ExplicitTuple es _) = check_es es
469 check_e other = Just other -- Fails
471 check_es es = foldr (seqMaybe . check_e) Nothing es
475 %*********************************************************
477 \subsection{Type, class and iface sig declarations}
479 %*********************************************************
481 @rnTyDecl@ uses the `global name function' to create a new type
482 declaration in which local names have been replaced by their original
483 names, reporting any unknown names.
485 Renaming type variables is a pain. Because they now contain uniques,
486 it is necessary to pass in an association list which maps a parsed
487 tyvar to its @Name@ representation.
488 In some cases (type signatures of values),
489 it is even necessary to go over the type first
490 in order to get the set of tyvars used by it, make an assoc list,
491 and then go over it again to rename the tyvars!
492 However, we can also do some scoping checks at the same time.
495 rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
497 lookupTopBndrRn name `thenM` \ name' ->
498 rnHsType doc_str ty `thenM` \ ty' ->
499 mappM rnIdInfo id_infos `thenM` \ id_infos' ->
500 returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
502 doc_str = text "In the interface signature for" <+> quotes (ppr name)
504 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
506 lookupTopBndrRn name `thenM` \ name' ->
507 returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
509 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
510 tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
511 tcdDerivs = derivs, tcdLoc = src_loc})
512 = addSrcLoc src_loc $
513 lookupTopBndrRn tycon `thenM` \ tycon' ->
514 bindTyVarsRn data_doc tyvars $ \ tyvars' ->
515 rnContext data_doc context `thenM` \ context' ->
516 rn_derivs derivs `thenM` \ derivs' ->
517 checkDupOrQualNames data_doc con_names `thenM_`
519 rnConDecls tycon' condecls `thenM` \ condecls' ->
520 returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
521 tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
522 tcdDerivs = derivs', tcdLoc = src_loc})
524 data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
525 con_names = map conDeclName (visibleDataCons condecls)
527 rn_derivs Nothing = returnM Nothing
528 rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds')
530 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
531 = addSrcLoc src_loc $
532 lookupTopBndrRn name `thenM` \ name' ->
533 bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
534 rnHsType syn_doc ty `thenM` \ ty' ->
535 returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
537 syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
539 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
540 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
542 -- Used for both source and interface file decls
543 = addSrcLoc src_loc $
545 lookupTopBndrRn cname `thenM` \ cname' ->
547 -- Tyvars scope over superclass context and method signatures
548 bindTyVarsRn cls_doc tyvars $ \ tyvars' ->
550 -- Check the superclasses
551 rnContext cls_doc context `thenM` \ context' ->
553 -- Check the functional dependencies
554 rnFds cls_doc fds `thenM` \ fds' ->
556 -- Check the signatures
557 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
559 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
560 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
562 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_`
563 mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' ->
565 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
567 renameSigs non_op_sigs `thenM` \ non_ops' ->
568 checkSigs okClsDclSig binders non_ops' `thenM_`
569 -- Typechecker is responsible for checking that we only
570 -- give default-method bindings for things in this class.
571 -- The renamer *could* check this for class decls, but can't
572 -- for instance decls.
574 returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
575 tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
578 cls_doc = text "In the declaration for class" <+> ppr cname
579 sig_doc = text "In the signatures for class" <+> ppr cname
581 rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
583 lookupTopBndrRn op `thenM` \ op_name ->
585 -- Check the signature
586 rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty ->
588 -- Make the default-method name
591 -> -- Imported class that has a default method decl
592 lookupSysBndr dm_rdr_name `thenM` \ dm_name ->
593 returnM (DefMeth dm_name)
594 -- An imported class decl for a class decl that had an explicit default
595 -- method, mentions, rather than defines,
596 -- the default method, so we must arrange to pull it in
598 GenDefMeth -> returnM GenDefMeth
599 NoDefMeth -> returnM NoDefMeth
600 ) `thenM` \ dm_stuff' ->
602 returnM (ClassOpSig op_name dm_stuff' new_ty locn)
604 finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
605 -- Used for source file decls only
606 -- Renames the default-bindings of a class decl
607 finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
608 rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
609 -- There are some default-method bindings (abeit possibly empty) so
610 -- this is a source-code class declaration
611 = -- The newLocals call is tiresome: given a generic class decl
614 -- op {| x+y |} (Inl a) = ...
615 -- op {| x+y |} (Inr b) = ...
616 -- op {| a*b |} (a*b) = ...
617 -- we want to name both "x" tyvars with the same unique, so that they are
618 -- easy to group together in the typechecker.
621 extendTyVarEnvForMethodBinds tyvars $
622 getLocalRdrEnv `thenM` \ name_env ->
624 meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
625 gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
626 not (tv `elemRdrEnv` name_env)]
628 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_`
629 newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
630 rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) ->
631 returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
633 meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
635 finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
636 -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
637 -- This is important, because tyClDeclFVs should contain only the
638 -- FVs that are `needed' by the interface file declaration, and
639 -- derivings do not appear in this. It also means that the tcGroups
640 -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
641 = returnM (tycl_decl,
642 maybe emptyFVs extractHsCtxtTyNames derivings)
644 finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
645 -- Not a class declaration
648 For the method bindings in class and instance decls, we extend the
649 type variable environment iff -fglasgow-exts
652 extendTyVarEnvForMethodBinds tyvars thing_inside
653 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
654 if opt_GlasgowExts then
655 extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
661 %*********************************************************
663 \subsection{Support code for type/data declarations}
665 %*********************************************************
668 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
669 conDeclName (ConDecl n _ _ _ l) = (n,l)
671 rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
672 rnConDecls tycon Unknown = returnM Unknown
673 rnConDecls tycon (HasCons n) = returnM (HasCons n)
674 rnConDecls tycon (DataCons condecls)
675 = -- Check that there's at least one condecl,
676 -- or else we're reading an interface file, or -fglasgow-exts
677 (if null condecls then
678 doptM Opt_GlasgowExts `thenM` \ glaExts ->
679 getModeRn `thenM` \ mode ->
680 checkErr (glaExts || isInterfaceMode mode)
681 (emptyConDeclsErr tycon)
685 mappM rnConDecl condecls `thenM` \ condecls' ->
686 returnM (DataCons condecls')
688 rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl
689 rnConDecl (ConDecl name tvs cxt details locn)
691 checkConName name `thenM_`
692 lookupTopBndrRn name `thenM` \ new_name ->
694 bindTyVarsRn doc tvs $ \ new_tyvars ->
695 rnContext doc cxt `thenM` \ new_context ->
696 rnConDetails doc locn details `thenM` \ new_details ->
697 returnM (ConDecl new_name new_tyvars new_context new_details locn)
699 doc = text "In the definition of data constructor" <+> quotes (ppr name)
701 rnConDetails doc locn (PrefixCon tys)
702 = mappM (rnBangTy doc) tys `thenM` \ new_tys ->
703 returnM (PrefixCon new_tys)
705 rnConDetails doc locn (InfixCon ty1 ty2)
706 = rnBangTy doc ty1 `thenM` \ new_ty1 ->
707 rnBangTy doc ty2 `thenM` \ new_ty2 ->
708 returnM (InfixCon new_ty1 new_ty2)
710 rnConDetails doc locn (RecCon fields)
711 = checkDupOrQualNames doc field_names `thenM_`
712 mappM (rnField doc) fields `thenM` \ new_fields ->
713 returnM (RecCon new_fields)
715 field_names = [(fld, locn) | (fld, _) <- fields]
717 rnField doc (name, ty)
718 = lookupTopBndrRn name `thenM` \ new_name ->
719 rnBangTy doc ty `thenM` \ new_ty ->
720 returnM (new_name, new_ty)
722 rnBangTy doc (BangType s ty)
723 = rnHsType doc ty `thenM` \ new_ty ->
724 returnM (BangType s new_ty)
726 -- This data decl will parse OK
728 -- treating "a" as the constructor.
729 -- It is really hard to make the parser spot this malformation.
730 -- So the renamer has to check that the constructor is legal
732 -- We can get an operator as the constructor, even in the prefix form:
733 -- data T = :% Int Int
734 -- from interface files, which always print in prefix form
737 = checkErr (isRdrDataCon name) (badDataCon name)
741 %*********************************************************
743 \subsection{Support code to rename types}
745 %*********************************************************
748 rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]
754 = rnHsTyVars doc tys1 `thenM` \ tys1' ->
755 rnHsTyVars doc tys2 `thenM` \ tys2' ->
756 returnM (tys1', tys2')
758 rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
759 rnHsTyvar doc tyvar = lookupOccRn tyvar
762 %*********************************************************
766 %*********************************************************
769 rnIdInfo (HsWorker worker arity)
770 = lookupOccRn worker `thenM` \ worker' ->
771 returnM (HsWorker worker' arity)
773 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' ->
774 returnM (HsUnfold inline expr')
775 rnIdInfo (HsStrictness str) = returnM (HsStrictness str)
776 rnIdInfo (HsArity arity) = returnM (HsArity arity)
777 rnIdInfo HsNoCafRefs = returnM HsNoCafRefs
780 @UfCore@ expressions.
783 rnCoreExpr (UfType ty)
784 = rnHsType (text "unfolding type") ty `thenM` \ ty' ->
788 = lookupOccRn v `thenM` \ v' ->
794 rnCoreExpr (UfLitLit l ty)
795 = rnHsType (text "litlit") ty `thenM` \ ty' ->
796 returnM (UfLitLit l ty')
798 rnCoreExpr (UfFCall cc ty)
799 = rnHsType (text "ccall") ty `thenM` \ ty' ->
800 returnM (UfFCall cc ty')
802 rnCoreExpr (UfTuple (HsTupCon boxity arity) args)
803 = mappM rnCoreExpr args `thenM` \ args' ->
804 returnM (UfTuple (HsTupCon boxity arity) args')
806 rnCoreExpr (UfApp fun arg)
807 = rnCoreExpr fun `thenM` \ fun' ->
808 rnCoreExpr arg `thenM` \ arg' ->
809 returnM (UfApp fun' arg')
811 rnCoreExpr (UfCase scrut bndr alts)
812 = rnCoreExpr scrut `thenM` \ scrut' ->
813 bindCoreLocalRn bndr $ \ bndr' ->
814 mappM rnCoreAlt alts `thenM` \ alts' ->
815 returnM (UfCase scrut' bndr' alts')
817 rnCoreExpr (UfNote note expr)
818 = rnNote note `thenM` \ note' ->
819 rnCoreExpr expr `thenM` \ expr' ->
820 returnM (UfNote note' expr')
822 rnCoreExpr (UfLam bndr body)
823 = rnCoreBndr bndr $ \ bndr' ->
824 rnCoreExpr body `thenM` \ body' ->
825 returnM (UfLam bndr' body')
827 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
828 = rnCoreExpr rhs `thenM` \ rhs' ->
829 rnCoreBndr bndr $ \ bndr' ->
830 rnCoreExpr body `thenM` \ body' ->
831 returnM (UfLet (UfNonRec bndr' rhs') body')
833 rnCoreExpr (UfLet (UfRec pairs) body)
834 = rnCoreBndrs bndrs $ \ bndrs' ->
835 mappM rnCoreExpr rhss `thenM` \ rhss' ->
836 rnCoreExpr body `thenM` \ body' ->
837 returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
839 (bndrs, rhss) = unzip pairs
843 rnCoreBndr (UfValBinder name ty) thing_inside
844 = rnHsType doc ty `thenM` \ ty' ->
845 bindCoreLocalRn name $ \ name' ->
846 thing_inside (UfValBinder name' ty')
848 doc = text "unfolding id"
850 rnCoreBndr (UfTyBinder name kind) thing_inside
851 = bindCoreLocalRn name $ \ name' ->
852 thing_inside (UfTyBinder name' kind)
854 rnCoreBndrs [] thing_inside = thing_inside []
855 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
856 rnCoreBndrs bs $ \ names' ->
857 thing_inside (name':names')
861 rnCoreAlt (con, bndrs, rhs)
862 = rnUfCon con `thenM` \ con' ->
863 bindCoreLocalsRn bndrs $ \ bndrs' ->
864 rnCoreExpr rhs `thenM` \ rhs' ->
865 returnM (con', bndrs', rhs')
868 = rnHsType (text "unfolding coerce") ty `thenM` \ ty' ->
869 returnM (UfCoerce ty')
871 rnNote (UfSCC cc) = returnM (UfSCC cc)
872 rnNote UfInlineCall = returnM UfInlineCall
873 rnNote UfInlineMe = returnM UfInlineMe
879 rnUfCon (UfTupleAlt tup_con)
880 = returnM (UfTupleAlt tup_con)
882 rnUfCon (UfDataAlt con)
883 = lookupOccRn con `thenM` \ con' ->
884 returnM (UfDataAlt con')
886 rnUfCon (UfLitAlt lit)
887 = returnM (UfLitAlt lit)
889 rnUfCon (UfLitLitAlt lit ty)
890 = rnHsType (text "litlit") ty `thenM` \ ty' ->
891 returnM (UfLitLitAlt lit ty')
894 %*********************************************************
896 \subsection{Statistics}
898 %*********************************************************
901 rnStats :: [RenamedHsDecl] -- Imported decls
904 = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace ->
905 doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats ->
906 doptM Opt_D_dump_rn `thenM` \ dump_rn ->
907 getEps `thenM` \ eps ->
909 ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
911 (getRnStats eps imp_decls)) `thenM_`
914 getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
915 getRnStats eps imported_decls
916 = hcat [text "Renamer stats: ", stats]
918 n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
919 -- This is really only right for a one-shot compile
921 (decls_map, n_decls_slurped) = eps_decls eps
923 n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
924 -- Data, newtype, and class decls are in the decls_fm
925 -- under multiple names; the tycon/class, and each
926 -- constructor/class op too.
927 -- The 'True' selects just the 'main' decl
930 (insts_left, n_insts_slurped) = eps_insts eps
931 n_insts_left = length (bagToList insts_left)
933 (rules_left, n_rules_slurped) = eps_rules eps
934 n_rules_left = length (bagToList rules_left)
937 [int n_mods <+> text "interfaces read",
938 hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
939 int (n_decls_slurped + n_decls_left), text "read"],
940 hsep [ int n_insts_slurped, text "instance decls imported, out of",
941 int (n_insts_slurped + n_insts_left), text "read"],
942 hsep [ int n_rules_slurped, text "rule decls imported, out of",
943 int (n_rules_slurped + n_rules_left), text "read"]
947 %*********************************************************
951 %*********************************************************
955 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
957 badRuleLhsErr name lhs (Just bad_e)
958 = sep [ptext SLIT("Rule") <+> ftext name <> colon,
959 nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
960 ptext SLIT("in left-hand side:") <+> ppr lhs])]
962 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
965 = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
966 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
967 ptext SLIT("does not appear on left hand side")]
969 emptyConDeclsErr tycon
970 = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
971 nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
974 = sep [quotes (ptext SLIT("with")),
975 ptext SLIT("is deprecated, use"),
976 quotes (ptext SLIT("let")),
977 ptext SLIT("instead")]
980 = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4