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',fvBinds) ->
278 thing_inside (IPBinds binds' is_with)
282 %************************************************************************
284 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
286 %************************************************************************
289 rnIPBinds [] = returnM ([], emptyFVs)
290 rnIPBinds ((n, expr) : binds)
291 = newIPName n `thenM` \ name ->
292 rnExpr expr `thenM` \ (expr',fvExpr) ->
293 rnIPBinds binds `thenM` \ (binds',fvBinds) ->
294 returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
299 %*********************************************************
301 \subsection{Foreign declarations}
303 %*********************************************************
306 rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
307 = addSrcLoc src_loc $
308 lookupTopBndrRn name `thenM` \ name' ->
309 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
310 returnM (ForeignImport name' ty' spec isDeprec src_loc,
311 fvs `plusFV` extras spec)
313 extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
314 bindIOName, returnIOName]
317 rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
318 = addSrcLoc src_loc $
319 lookupOccRn name `thenM` \ name' ->
320 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
321 returnM (ForeignExport name' ty' spec isDeprec src_loc,
322 mkFVs [name', bindIOName, returnIOName] `plusFV` fvs )
323 -- NB: a foreign export is an *occurrence site* for name, so
324 -- we add it to the free-variable list. It might, for example,
325 -- be imported from another module
327 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
331 %*********************************************************
333 \subsection{Instance declarations}
335 %*********************************************************
338 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
339 -- Used for both source and interface file decls
340 = addSrcLoc src_loc $
341 rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
343 (case maybe_dfun_rdr_name of
344 Nothing -> returnM Nothing
345 Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name ->
346 returnM (Just dfun_name)
347 ) `thenM` \ maybe_dfun_name ->
349 -- The typechecker checks that all the bindings are for the right class.
350 returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
352 -- Compare finishSourceTyClDecl
353 finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
354 (InstDecl inst_ty _ _ maybe_dfun_name src_loc)
355 -- Used for both source decls only
356 = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
358 meth_doc = text "In the bindings in an instance declaration"
359 meth_names = collectLocatedMonoBinders mbinds
360 (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
361 -- (Slightly strangely) the forall-d tyvars scope over
362 -- the method bindings too
365 -- Rename the bindings
366 -- NB meth_names can be qualified!
367 checkDupNames meth_doc meth_names `thenM_`
368 extendTyVarEnvForMethodBinds inst_tyvars (
369 rnMethodBinds cls [] mbinds
370 ) `thenM` \ (mbinds', meth_fvs) ->
372 binders = collectMonoBinders mbinds'
374 -- Rename the prags and signatures.
375 -- Note that the type variables are not in scope here,
376 -- so that instance Eq a => Eq (T a) where
377 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
380 -- But the (unqualified) method names are in scope
381 bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' ->
382 checkSigs okInstDclSig (mkNameSet binders) uprags' `thenM_`
384 returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
385 meth_fvs `plusFV` hsSigsFVs uprags')
388 %*********************************************************
392 %*********************************************************
395 rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
396 = addSrcLoc src_loc $
397 lookupOccRn fn `thenM` \ fn' ->
398 rnCoreBndrs vars $ \ vars' ->
399 mappM rnCoreExpr args `thenM` \ args' ->
400 rnCoreExpr rhs `thenM` \ rhs' ->
401 returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
403 rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way
404 = lookupOccRn fn `thenM` \ fn' ->
405 returnM (IfaceRuleOut fn' rule)
407 rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
408 = addSrcLoc src_loc $
409 bindPatSigTyVars (collectRuleBndrSigTys vars) $
411 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
412 mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
414 rnExpr lhs `thenM` \ (lhs', fv_lhs) ->
415 rnExpr rhs `thenM` \ (rhs', fv_rhs) ->
417 mb_bad = validRuleLhs ids lhs'
419 checkErr (isNothing mb_bad)
420 (badRuleLhsErr rule_name lhs' mb_bad) `thenM_`
422 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
424 mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
425 returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
426 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
428 doc = text "In the transformation rule" <+> ftext rule_name
430 get_var (RuleBndr v) = v
431 get_var (RuleBndrSig v _) = v
433 rn_var (RuleBndr v, id) = returnM (RuleBndr id, emptyFVs)
434 rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
435 returnM (RuleBndrSig id t', fvs)
438 Check the shape of a transformation rule LHS. Currently
439 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
440 not one of the @forall@'d variables. We also restrict the form of the LHS so
441 that it may be plausibly matched. Basically you only get to write ordinary
442 applications. (E.g. a case expression is not allowed: too elaborate.)
444 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
447 validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr
449 -- Just e => Not ok, and e is the offending expression
450 validRuleLhs foralls lhs
453 check (OpApp e1 op _ e2) = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2
454 check (HsApp e1 e2) = check e1 `seqMaybe` check_e e2
455 check (HsVar v) | v `notElem` foralls = Nothing
456 check other = Just other -- Failure
458 check_e (HsVar v) = Nothing
459 check_e (HsPar e) = check_e e
460 check_e (HsLit e) = Nothing
461 check_e (HsOverLit e) = Nothing
463 check_e (OpApp e1 op _ e2) = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2
464 check_e (HsApp e1 e2) = check_e e1 `seqMaybe` check_e e2
465 check_e (NegApp e _) = check_e e
466 check_e (ExplicitList _ es) = check_es es
467 check_e (ExplicitTuple es _) = check_es es
468 check_e other = Just other -- Fails
470 check_es es = foldr (seqMaybe . check_e) Nothing es
474 %*********************************************************
476 \subsection{Type, class and iface sig declarations}
478 %*********************************************************
480 @rnTyDecl@ uses the `global name function' to create a new type
481 declaration in which local names have been replaced by their original
482 names, reporting any unknown names.
484 Renaming type variables is a pain. Because they now contain uniques,
485 it is necessary to pass in an association list which maps a parsed
486 tyvar to its @Name@ representation.
487 In some cases (type signatures of values),
488 it is even necessary to go over the type first
489 in order to get the set of tyvars used by it, make an assoc list,
490 and then go over it again to rename the tyvars!
491 However, we can also do some scoping checks at the same time.
494 rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
496 lookupTopBndrRn name `thenM` \ name' ->
497 rnHsType doc_str ty `thenM` \ ty' ->
498 mappM rnIdInfo id_infos `thenM` \ id_infos' ->
499 returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
501 doc_str = text "In the interface signature for" <+> quotes (ppr name)
503 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
505 lookupTopBndrRn name `thenM` \ name' ->
506 returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
508 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
509 tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
510 tcdDerivs = derivs, tcdLoc = src_loc})
511 = addSrcLoc src_loc $
512 lookupTopBndrRn tycon `thenM` \ tycon' ->
513 bindTyVarsRn data_doc tyvars $ \ tyvars' ->
514 rnContext data_doc context `thenM` \ context' ->
515 rn_derivs derivs `thenM` \ derivs' ->
516 checkDupOrQualNames data_doc con_names `thenM_`
518 rnConDecls tycon' condecls `thenM` \ condecls' ->
519 returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
520 tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
521 tcdDerivs = derivs', tcdLoc = src_loc})
523 data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
524 con_names = map conDeclName (visibleDataCons condecls)
526 rn_derivs Nothing = returnM Nothing
527 rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds')
529 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
530 = addSrcLoc src_loc $
531 lookupTopBndrRn name `thenM` \ name' ->
532 bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
533 rnHsType syn_doc ty `thenM` \ ty' ->
534 returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
536 syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
538 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
539 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
541 -- Used for both source and interface file decls
542 = addSrcLoc src_loc $
544 lookupTopBndrRn cname `thenM` \ cname' ->
546 -- Tyvars scope over superclass context and method signatures
547 bindTyVarsRn cls_doc tyvars $ \ tyvars' ->
549 -- Check the superclasses
550 rnContext cls_doc context `thenM` \ context' ->
552 -- Check the functional dependencies
553 rnFds cls_doc fds `thenM` \ fds' ->
555 -- Check the signatures
556 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
558 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
559 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
561 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_`
562 mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' ->
564 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
566 renameSigs non_op_sigs `thenM` \ non_ops' ->
567 checkSigs okClsDclSig binders non_ops' `thenM_`
568 -- Typechecker is responsible for checking that we only
569 -- give default-method bindings for things in this class.
570 -- The renamer *could* check this for class decls, but can't
571 -- for instance decls.
573 returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
574 tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
577 cls_doc = text "In the declaration for class" <+> ppr cname
578 sig_doc = text "In the signatures for class" <+> ppr cname
580 rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
582 lookupTopBndrRn op `thenM` \ op_name ->
584 -- Check the signature
585 rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty ->
587 -- Make the default-method name
590 -> -- Imported class that has a default method decl
591 lookupSysBndr dm_rdr_name `thenM` \ dm_name ->
592 returnM (DefMeth dm_name)
593 -- An imported class decl for a class decl that had an explicit default
594 -- method, mentions, rather than defines,
595 -- the default method, so we must arrange to pull it in
597 GenDefMeth -> returnM GenDefMeth
598 NoDefMeth -> returnM NoDefMeth
599 ) `thenM` \ dm_stuff' ->
601 returnM (ClassOpSig op_name dm_stuff' new_ty locn)
603 finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
604 -- Used for source file decls only
605 -- Renames the default-bindings of a class decl
606 finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
607 rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
608 -- There are some default-method bindings (abeit possibly empty) so
609 -- this is a source-code class declaration
610 = -- The newLocals call is tiresome: given a generic class decl
613 -- op {| x+y |} (Inl a) = ...
614 -- op {| x+y |} (Inr b) = ...
615 -- op {| a*b |} (a*b) = ...
616 -- we want to name both "x" tyvars with the same unique, so that they are
617 -- easy to group together in the typechecker.
620 extendTyVarEnvForMethodBinds tyvars $
621 getLocalRdrEnv `thenM` \ name_env ->
623 meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
624 gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
625 not (tv `elemRdrEnv` name_env)]
627 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_`
628 newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
629 rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) ->
630 returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
632 meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
634 finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
635 -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
636 -- This is important, because tyClDeclFVs should contain only the
637 -- FVs that are `needed' by the interface file declaration, and
638 -- derivings do not appear in this. It also means that the tcGroups
639 -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
640 = returnM (tycl_decl,
641 maybe emptyFVs extractHsCtxtTyNames derivings)
643 finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
644 -- Not a class declaration
647 For the method bindings in class and instance decls, we extend the
648 type variable environment iff -fglasgow-exts
651 extendTyVarEnvForMethodBinds tyvars thing_inside
652 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
653 if opt_GlasgowExts then
654 extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
660 %*********************************************************
662 \subsection{Support code for type/data declarations}
664 %*********************************************************
667 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
668 conDeclName (ConDecl n _ _ _ l) = (n,l)
670 rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
671 rnConDecls tycon Unknown = returnM Unknown
672 rnConDecls tycon (HasCons n) = returnM (HasCons n)
673 rnConDecls tycon (DataCons condecls)
674 = -- Check that there's at least one condecl,
675 -- or else we're reading an interface file, or -fglasgow-exts
676 (if null condecls then
677 doptM Opt_GlasgowExts `thenM` \ glaExts ->
678 getModeRn `thenM` \ mode ->
679 checkErr (glaExts || isInterfaceMode mode)
680 (emptyConDeclsErr tycon)
684 mappM rnConDecl condecls `thenM` \ condecls' ->
685 returnM (DataCons condecls')
687 rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl
688 rnConDecl (ConDecl name tvs cxt details locn)
690 checkConName name `thenM_`
691 lookupTopBndrRn name `thenM` \ new_name ->
693 bindTyVarsRn doc tvs $ \ new_tyvars ->
694 rnContext doc cxt `thenM` \ new_context ->
695 rnConDetails doc locn details `thenM` \ new_details ->
696 returnM (ConDecl new_name new_tyvars new_context new_details locn)
698 doc = text "In the definition of data constructor" <+> quotes (ppr name)
700 rnConDetails doc locn (PrefixCon tys)
701 = mappM (rnBangTy doc) tys `thenM` \ new_tys ->
702 returnM (PrefixCon new_tys)
704 rnConDetails doc locn (InfixCon ty1 ty2)
705 = rnBangTy doc ty1 `thenM` \ new_ty1 ->
706 rnBangTy doc ty2 `thenM` \ new_ty2 ->
707 returnM (InfixCon new_ty1 new_ty2)
709 rnConDetails doc locn (RecCon fields)
710 = checkDupOrQualNames doc field_names `thenM_`
711 mappM (rnField doc) fields `thenM` \ new_fields ->
712 returnM (RecCon new_fields)
714 field_names = [(fld, locn) | (fld, _) <- fields]
716 rnField doc (name, ty)
717 = lookupTopBndrRn name `thenM` \ new_name ->
718 rnBangTy doc ty `thenM` \ new_ty ->
719 returnM (new_name, new_ty)
721 rnBangTy doc (BangType s ty)
722 = rnHsType doc ty `thenM` \ new_ty ->
723 returnM (BangType s new_ty)
725 -- This data decl will parse OK
727 -- treating "a" as the constructor.
728 -- It is really hard to make the parser spot this malformation.
729 -- So the renamer has to check that the constructor is legal
731 -- We can get an operator as the constructor, even in the prefix form:
732 -- data T = :% Int Int
733 -- from interface files, which always print in prefix form
736 = checkErr (isRdrDataCon name) (badDataCon name)
740 %*********************************************************
742 \subsection{Support code to rename types}
744 %*********************************************************
747 rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]
753 = rnHsTyVars doc tys1 `thenM` \ tys1' ->
754 rnHsTyVars doc tys2 `thenM` \ tys2' ->
755 returnM (tys1', tys2')
757 rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
758 rnHsTyvar doc tyvar = lookupOccRn tyvar
761 %*********************************************************
765 %*********************************************************
768 rnIdInfo (HsWorker worker arity)
769 = lookupOccRn worker `thenM` \ worker' ->
770 returnM (HsWorker worker' arity)
772 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' ->
773 returnM (HsUnfold inline expr')
774 rnIdInfo (HsStrictness str) = returnM (HsStrictness str)
775 rnIdInfo (HsArity arity) = returnM (HsArity arity)
776 rnIdInfo HsNoCafRefs = returnM HsNoCafRefs
779 @UfCore@ expressions.
782 rnCoreExpr (UfType ty)
783 = rnHsType (text "unfolding type") ty `thenM` \ ty' ->
787 = lookupOccRn v `thenM` \ v' ->
793 rnCoreExpr (UfLitLit l ty)
794 = rnHsType (text "litlit") ty `thenM` \ ty' ->
795 returnM (UfLitLit l ty')
797 rnCoreExpr (UfFCall cc ty)
798 = rnHsType (text "ccall") ty `thenM` \ ty' ->
799 returnM (UfFCall cc ty')
801 rnCoreExpr (UfTuple (HsTupCon boxity arity) args)
802 = mappM rnCoreExpr args `thenM` \ args' ->
803 returnM (UfTuple (HsTupCon boxity arity) args')
805 rnCoreExpr (UfApp fun arg)
806 = rnCoreExpr fun `thenM` \ fun' ->
807 rnCoreExpr arg `thenM` \ arg' ->
808 returnM (UfApp fun' arg')
810 rnCoreExpr (UfCase scrut bndr alts)
811 = rnCoreExpr scrut `thenM` \ scrut' ->
812 bindCoreLocalRn bndr $ \ bndr' ->
813 mappM rnCoreAlt alts `thenM` \ alts' ->
814 returnM (UfCase scrut' bndr' alts')
816 rnCoreExpr (UfNote note expr)
817 = rnNote note `thenM` \ note' ->
818 rnCoreExpr expr `thenM` \ expr' ->
819 returnM (UfNote note' expr')
821 rnCoreExpr (UfLam bndr body)
822 = rnCoreBndr bndr $ \ bndr' ->
823 rnCoreExpr body `thenM` \ body' ->
824 returnM (UfLam bndr' body')
826 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
827 = rnCoreExpr rhs `thenM` \ rhs' ->
828 rnCoreBndr bndr $ \ bndr' ->
829 rnCoreExpr body `thenM` \ body' ->
830 returnM (UfLet (UfNonRec bndr' rhs') body')
832 rnCoreExpr (UfLet (UfRec pairs) body)
833 = rnCoreBndrs bndrs $ \ bndrs' ->
834 mappM rnCoreExpr rhss `thenM` \ rhss' ->
835 rnCoreExpr body `thenM` \ body' ->
836 returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
838 (bndrs, rhss) = unzip pairs
842 rnCoreBndr (UfValBinder name ty) thing_inside
843 = rnHsType doc ty `thenM` \ ty' ->
844 bindCoreLocalRn name $ \ name' ->
845 thing_inside (UfValBinder name' ty')
847 doc = text "unfolding id"
849 rnCoreBndr (UfTyBinder name kind) thing_inside
850 = bindCoreLocalRn name $ \ name' ->
851 thing_inside (UfTyBinder name' kind)
853 rnCoreBndrs [] thing_inside = thing_inside []
854 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
855 rnCoreBndrs bs $ \ names' ->
856 thing_inside (name':names')
860 rnCoreAlt (con, bndrs, rhs)
861 = rnUfCon con `thenM` \ con' ->
862 bindCoreLocalsRn bndrs $ \ bndrs' ->
863 rnCoreExpr rhs `thenM` \ rhs' ->
864 returnM (con', bndrs', rhs')
867 = rnHsType (text "unfolding coerce") ty `thenM` \ ty' ->
868 returnM (UfCoerce ty')
870 rnNote (UfSCC cc) = returnM (UfSCC cc)
871 rnNote UfInlineCall = returnM UfInlineCall
872 rnNote UfInlineMe = returnM UfInlineMe
878 rnUfCon (UfTupleAlt tup_con)
879 = returnM (UfTupleAlt tup_con)
881 rnUfCon (UfDataAlt con)
882 = lookupOccRn con `thenM` \ con' ->
883 returnM (UfDataAlt con')
885 rnUfCon (UfLitAlt lit)
886 = returnM (UfLitAlt lit)
888 rnUfCon (UfLitLitAlt lit ty)
889 = rnHsType (text "litlit") ty `thenM` \ ty' ->
890 returnM (UfLitLitAlt lit ty')
893 %*********************************************************
895 \subsection{Statistics}
897 %*********************************************************
900 rnStats :: [RenamedHsDecl] -- Imported decls
903 = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace ->
904 doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats ->
905 doptM Opt_D_dump_rn `thenM` \ dump_rn ->
906 getEps `thenM` \ eps ->
908 ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
910 (getRnStats eps imp_decls)) `thenM_`
913 getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
914 getRnStats eps imported_decls
915 = hcat [text "Renamer stats: ", stats]
917 n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
918 -- This is really only right for a one-shot compile
920 (decls_map, n_decls_slurped) = eps_decls eps
922 n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
923 -- Data, newtype, and class decls are in the decls_fm
924 -- under multiple names; the tycon/class, and each
925 -- constructor/class op too.
926 -- The 'True' selects just the 'main' decl
929 (insts_left, n_insts_slurped) = eps_insts eps
930 n_insts_left = length (bagToList insts_left)
932 (rules_left, n_rules_slurped) = eps_rules eps
933 n_rules_left = length (bagToList rules_left)
936 [int n_mods <+> text "interfaces read",
937 hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
938 int (n_decls_slurped + n_decls_left), text "read"],
939 hsep [ int n_insts_slurped, text "instance decls imported, out of",
940 int (n_insts_slurped + n_insts_left), text "read"],
941 hsep [ int n_rules_slurped, text "rule decls imported, out of",
942 int (n_rules_slurped + n_rules_left), text "read"]
946 %*********************************************************
950 %*********************************************************
954 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
956 badRuleLhsErr name lhs (Just bad_e)
957 = sep [ptext SLIT("Rule") <+> ftext name <> colon,
958 nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
959 ptext SLIT("in left-hand side:") <+> ppr lhs])]
961 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
964 = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
965 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
966 ptext SLIT("does not appear on left hand side")]
968 emptyConDeclsErr tycon
969 = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
970 nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
973 = sep [quotes (ptext SLIT("with")),
974 ptext SLIT("is deprecated, use"),
975 quotes (ptext SLIT("let")),
976 ptext SLIT("instead")]
979 = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4