2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
8 rnSrcDecls, rnExtCoreDecls, checkModDeprec,
9 rnTyClDecl, rnIfaceRuleDecl, rnInstDecl,
10 rnBinds, rnBindsAndThen, rnStats,
13 #include "HsVersions.h"
16 import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
17 import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl,
18 RdrNameDeprecation, RdrNameFixitySig,
20 extractGenericPatTyVars
25 import RnNames ( importsFromLocalDecls )
26 import RnExpr ( rnExpr )
27 import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
29 import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
30 rnMonoBindsAndThen, renameSigs, checkSigs )
31 import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
32 newLocalsRn, lookupGlobalOccRn,
33 bindLocalsFVRn, bindPatSigTyVars,
34 bindTyVarsRn, extendTyVarEnvFVRn,
35 bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
36 checkDupOrQualNames, checkDupNames, mapFvRn,
37 lookupTopSrcBndr_maybe, lookupTopSrcBndr,
38 dataTcOccs, unknownNameErr,
43 import BasicTypes ( FixitySig(..) )
44 import HscTypes ( ExternalPackageState(..), FixityEnv,
45 Deprecations(..), plusDeprecs )
46 import Module ( moduleEnvElts )
47 import Class ( FunDep, DefMeth (..) )
48 import TyCon ( DataConDetails(..), visibleDataCons )
52 import ErrUtils ( dumpIfSet )
53 import PrelNames ( newStablePtrName, bindIOName, returnIOName )
54 import List ( partition )
55 import Bag ( bagToList )
57 import SrcLoc ( SrcLoc )
58 import CmdLineOpts ( DynFlag(..) )
59 -- Warn of unused for-all'd tyvars
60 import Maybes ( maybeToBool, seqMaybe )
61 import Maybe ( maybe, catMaybes, isNothing )
64 @rnSourceDecl@ `renames' declarations.
65 It simultaneously performs dependency analysis and precedence parsing.
66 It also does the following error checks:
69 Checks that tyvars are used properly. This includes checking
70 for undefined tyvars, and tyvars in contexts that are ambiguous.
71 (Some of this checking has now been moved to module @TcMonoType@,
72 since we don't have functional dependency information at this point.)
74 Checks that all variable occurences are defined.
76 Checks the @(..)@ etc constraints in the export list.
81 rnSrcDecls :: [RdrNameHsDecl] -> RnM (TcGblEnv, [RenamedHsDecl], FreeVars)
84 = do { (rdr_env, imports) <- importsFromLocalDecls decls ;
85 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
87 tcg_imports = imports `plusImportAvails`
91 -- Deal with deprecations (returns only the extra deprecations)
92 deprecs <- rnSrcDeprecDecls [d | DeprecD d <- decls] ;
93 updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
96 -- Deal with top-level fixity decls
97 -- (returns the total new fixity env)
98 fix_env <- rnSrcFixityDecls decls ;
99 updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
102 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
104 -- Rename remaining declarations
105 (rn_src_decls, src_fvs) <- rn_src_decls decls ;
107 tcg_env <- getGblEnv ;
108 return (tcg_env, rn_src_decls, src_fvs)
111 rnExtCoreDecls :: [RdrNameHsDecl] -> RnM ([RenamedHsDecl], FreeVars)
112 rnExtCoreDecls decls = rn_src_decls decls
114 rn_src_decls decls -- Declarartions get reversed, but no matter
115 = go emptyFVs [] decls
117 -- Fixity and deprecations have been dealt with already; ignore them
118 go fvs ds' [] = returnM (ds', fvs)
119 go fvs ds' (FixD _:ds) = go fvs ds' ds
120 go fvs ds' (DeprecD _:ds) = go fvs ds' ds
121 go fvs ds' (d:ds) = rnSrcDecl d `thenM` \(d', fvs') ->
122 go (fvs `plusFV` fvs') (d':ds') ds
126 %*********************************************************
128 Source-code fixity declarations
130 %*********************************************************
133 rnSrcFixityDecls :: [RdrNameHsDecl] -> TcRn m FixityEnv
134 rnSrcFixityDecls decls
135 = getGblEnv `thenM` \ gbl_env ->
136 foldlM rnFixityDecl (tcg_fix_env gbl_env)
137 fix_decls `thenM` \ fix_env ->
138 traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
141 fix_decls = foldr get_fix_sigs [] decls
143 -- Get fixities from top level decls, and from class decl sigs too
144 get_fix_sigs (FixD fix) acc = fix:acc
145 get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
146 = [sig | FixSig sig <- sigs] ++ acc
147 get_fix_sigs other_decl acc = acc
149 rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
150 rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
151 = -- GHC extension: look up both the tycon and data con
152 -- for con-like things
153 -- If neither are in scope, report an error; otherwise
154 -- add both to the fixity env
155 mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns ->
156 case catMaybes maybe_ns of
157 [] -> addSrcLoc loc $
158 addErr (unknownNameErr rdr_name) `thenM_`
160 ns -> foldlM add fix_env ns
163 = case lookupNameEnv fix_env name of
164 Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_`
166 Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc))
168 dupFixityDecl rdr_name loc1 loc2
169 = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
170 ptext SLIT("at ") <+> ppr loc1,
171 ptext SLIT("and") <+> ppr loc2]
175 %*********************************************************
177 Source-code deprecations declarations
179 %*********************************************************
181 For deprecations, all we do is check that the names are in scope.
182 It's only imported deprecations, dealt with in RnIfaces, that we
183 gather them together.
186 rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations
190 rnSrcDeprecDecls decls
191 = mappM rn_deprec decls `thenM` \ pairs ->
192 returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
194 rn_deprec (Deprecation rdr_name txt loc)
196 lookupTopSrcBndr rdr_name `thenM` \ name ->
197 returnM (Just (name, (name,txt)))
199 checkModDeprec :: Maybe DeprecTxt -> Deprecations
200 -- Check for a module deprecation; done once at top level
201 checkModDeprec Nothing = NoDeprecs
202 checkModdeprec (Just txt) = DeprecAll txt
205 = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
209 %*********************************************************
211 \subsection{Source code declarations}
213 %*********************************************************
216 rnSrcDecl :: RdrNameHsDecl -> RnM (RenamedHsDecl, FreeVars)
218 rnSrcDecl (ValD binds) = rnTopBinds binds `thenM` \ (new_binds, fvs) ->
219 returnM (ValD new_binds, fvs)
221 rnSrcDecl (TyClD tycl_decl)
222 = rnTyClDecl tycl_decl `thenM` \ new_decl ->
223 finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) ->
224 returnM (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
226 rnSrcDecl (InstD inst)
227 = rnInstDecl inst `thenM` \ new_inst ->
228 finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) ->
229 returnM (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
231 rnSrcDecl (RuleD rule)
232 = rnHsRuleDecl rule `thenM` \ (new_rule, fvs) ->
233 returnM (RuleD new_rule, fvs)
235 rnSrcDecl (ForD ford)
236 = rnHsForeignDecl ford `thenM` \ (new_ford, fvs) ->
237 returnM (ForD new_ford, fvs)
239 rnSrcDecl (DefD (DefaultDecl tys src_loc))
240 = addSrcLoc src_loc $
241 mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
242 returnM (DefD (DefaultDecl tys' src_loc), fvs)
244 doc_str = text "In a `default' declaration"
247 rnSrcDecl (CoreD (CoreDecl name ty rhs loc))
249 lookupTopBndrRn name `thenM` \ name' ->
250 rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) ->
251 rnCoreExpr rhs `thenM` \ rhs' ->
252 returnM (CoreD (CoreDecl name' ty' rhs' loc),
253 ty_fvs `plusFV` ufExprFVs rhs')
255 doc_str = text "In the Core declaration for" <+> quotes (ppr name)
258 %*********************************************************
262 %*********************************************************
264 These chaps are here, rather than in TcBinds, so that there
265 is just one hi-boot file (for RnSource). rnSrcDecls is part
266 of the loop too, and it must be defined in this module.
269 rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
270 rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
271 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
272 -- The parser doesn't produce other forms
274 rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
275 -- This version assumes that the binders are already in scope
276 rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
277 rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
278 -- The parser doesn't produce other forms
280 rnBindsAndThen :: RdrNameHsBinds
281 -> (RenamedHsBinds -> RnM (result, FreeVars))
282 -> RnM (result, FreeVars)
283 -- This version (a) assumes that the binding vars are not already in scope
284 -- (b) removes the binders from the free vars of the thing inside
285 rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds
286 rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside
287 -- The parser doesn't produce other forms
291 %*********************************************************
293 \subsection{Foreign declarations}
295 %*********************************************************
298 rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
299 = addSrcLoc src_loc $
300 lookupTopBndrRn name `thenM` \ name' ->
301 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
302 returnM (ForeignImport name' ty' spec isDeprec src_loc,
303 fvs `plusFV` extras spec)
305 extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
306 bindIOName, returnIOName]
309 rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
310 = addSrcLoc src_loc $
311 lookupOccRn name `thenM` \ name' ->
312 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
313 returnM (ForeignExport name' ty' spec isDeprec src_loc,
314 mkFVs [name', bindIOName, returnIOName] `plusFV` fvs )
315 -- NB: a foreign export is an *occurrence site* for name, so
316 -- we add it to the free-variable list. It might, for example,
317 -- be imported from another module
319 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
323 %*********************************************************
325 \subsection{Instance declarations}
327 %*********************************************************
330 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
331 -- Used for both source and interface file decls
332 = addSrcLoc src_loc $
333 rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
335 (case maybe_dfun_rdr_name of
336 Nothing -> returnM Nothing
337 Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name ->
338 returnM (Just dfun_name)
339 ) `thenM` \ maybe_dfun_name ->
341 -- The typechecker checks that all the bindings are for the right class.
342 returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
344 -- Compare finishSourceTyClDecl
345 finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
346 (InstDecl inst_ty _ _ maybe_dfun_name src_loc)
347 -- Used for both source decls only
348 = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
350 meth_doc = text "In the bindings in an instance declaration"
351 meth_names = collectLocatedMonoBinders mbinds
352 (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
353 -- (Slightly strangely) the forall-d tyvars scope over
354 -- the method bindings too
357 -- Rename the bindings
358 -- NB meth_names can be qualified!
359 checkDupNames meth_doc meth_names `thenM_`
360 extendTyVarEnvForMethodBinds inst_tyvars (
361 rnMethodBinds cls [] mbinds
362 ) `thenM` \ (mbinds', meth_fvs) ->
364 binders = collectMonoBinders mbinds'
366 -- Rename the prags and signatures.
367 -- Note that the type variables are not in scope here,
368 -- so that instance Eq a => Eq (T a) where
369 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
372 -- But the (unqualified) method names are in scope
373 bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' ->
374 checkSigs okInstDclSig (mkNameSet binders) uprags' `thenM_`
376 returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
377 meth_fvs `plusFV` hsSigsFVs uprags')
380 %*********************************************************
384 %*********************************************************
387 rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
388 = addSrcLoc src_loc $
389 lookupOccRn fn `thenM` \ fn' ->
390 rnCoreBndrs vars $ \ vars' ->
391 mappM rnCoreExpr args `thenM` \ args' ->
392 rnCoreExpr rhs `thenM` \ rhs' ->
393 returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
395 rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way
396 = lookupOccRn fn `thenM` \ fn' ->
397 returnM (IfaceRuleOut fn' rule)
399 rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
400 = addSrcLoc src_loc $
401 bindPatSigTyVars (collectRuleBndrSigTys vars) $
403 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
404 mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
406 rnExpr lhs `thenM` \ (lhs', fv_lhs) ->
407 rnExpr rhs `thenM` \ (rhs', fv_rhs) ->
409 mb_bad = validRuleLhs ids lhs'
411 checkErr (isNothing mb_bad)
412 (badRuleLhsErr rule_name lhs' mb_bad) `thenM_`
414 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
416 mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
417 returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
418 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
420 doc = text "In the transformation rule" <+> ftext rule_name
422 get_var (RuleBndr v) = v
423 get_var (RuleBndrSig v _) = v
425 rn_var (RuleBndr v, id) = returnM (RuleBndr id, emptyFVs)
426 rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
427 returnM (RuleBndrSig id t', fvs)
430 Check the shape of a transformation rule LHS. Currently
431 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
432 not one of the @forall@'d variables. We also restrict the form of the LHS so
433 that it may be plausibly matched. Basically you only get to write ordinary
434 applications. (E.g. a case expression is not allowed: too elaborate.)
436 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
439 validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr
441 -- Just e => Not ok, and e is the offending expression
442 validRuleLhs foralls lhs
445 check (OpApp e1 op _ e2) = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2
446 check (HsApp e1 e2) = check e1 `seqMaybe` check_e e2
447 check (HsVar v) | v `notElem` foralls = Nothing
448 check other = Just other -- Failure
450 check_e (HsVar v) = Nothing
451 check_e (HsPar e) = check_e e
452 check_e (HsLit e) = Nothing
453 check_e (HsOverLit e) = Nothing
455 check_e (OpApp e1 op _ e2) = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2
456 check_e (HsApp e1 e2) = check_e e1 `seqMaybe` check_e e2
457 check_e (NegApp e _) = check_e e
458 check_e (ExplicitList _ es) = check_es es
459 check_e (ExplicitTuple es _) = check_es es
460 check_e other = Just other -- Fails
462 check_es es = foldr (seqMaybe . check_e) Nothing es
466 %*********************************************************
468 \subsection{Type, class and iface sig declarations}
470 %*********************************************************
472 @rnTyDecl@ uses the `global name function' to create a new type
473 declaration in which local names have been replaced by their original
474 names, reporting any unknown names.
476 Renaming type variables is a pain. Because they now contain uniques,
477 it is necessary to pass in an association list which maps a parsed
478 tyvar to its @Name@ representation.
479 In some cases (type signatures of values),
480 it is even necessary to go over the type first
481 in order to get the set of tyvars used by it, make an assoc list,
482 and then go over it again to rename the tyvars!
483 However, we can also do some scoping checks at the same time.
486 rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
488 lookupTopBndrRn name `thenM` \ name' ->
489 rnHsType doc_str ty `thenM` \ ty' ->
490 mappM rnIdInfo id_infos `thenM` \ id_infos' ->
491 returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
493 doc_str = text "In the interface signature for" <+> quotes (ppr name)
495 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
497 lookupTopBndrRn name `thenM` \ name' ->
498 returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
500 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
501 tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
502 tcdDerivs = derivs, tcdLoc = src_loc})
503 = addSrcLoc src_loc $
504 lookupTopBndrRn tycon `thenM` \ tycon' ->
505 bindTyVarsRn data_doc tyvars $ \ tyvars' ->
506 rnContext data_doc context `thenM` \ context' ->
507 rn_derivs derivs `thenM` \ derivs' ->
508 checkDupOrQualNames data_doc con_names `thenM_`
510 rnConDecls tycon' condecls `thenM` \ condecls' ->
511 returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
512 tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
513 tcdDerivs = derivs', tcdLoc = src_loc})
515 data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
516 con_names = map conDeclName (visibleDataCons condecls)
518 rn_derivs Nothing = returnM Nothing
519 rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds')
521 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
522 = addSrcLoc src_loc $
523 lookupTopBndrRn name `thenM` \ name' ->
524 bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
525 rnHsType syn_doc ty `thenM` \ ty' ->
526 returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
528 syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
530 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
531 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
533 -- Used for both source and interface file decls
534 = addSrcLoc src_loc $
536 lookupTopBndrRn cname `thenM` \ cname' ->
538 -- Tyvars scope over superclass context and method signatures
539 bindTyVarsRn cls_doc tyvars $ \ tyvars' ->
541 -- Check the superclasses
542 rnContext cls_doc context `thenM` \ context' ->
544 -- Check the functional dependencies
545 rnFds cls_doc fds `thenM` \ fds' ->
547 -- Check the signatures
548 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
550 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
551 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
553 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_`
554 mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' ->
556 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
558 renameSigs non_op_sigs `thenM` \ non_ops' ->
559 checkSigs okClsDclSig binders non_ops' `thenM_`
560 -- Typechecker is responsible for checking that we only
561 -- give default-method bindings for things in this class.
562 -- The renamer *could* check this for class decls, but can't
563 -- for instance decls.
565 returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
566 tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
569 cls_doc = text "In the declaration for class" <+> ppr cname
570 sig_doc = text "In the signatures for class" <+> ppr cname
572 rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
574 lookupTopBndrRn op `thenM` \ op_name ->
576 -- Check the signature
577 rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty ->
579 -- Make the default-method name
582 -> -- Imported class that has a default method decl
583 lookupSysBndr dm_rdr_name `thenM` \ dm_name ->
584 returnM (DefMeth dm_name)
585 -- An imported class decl for a class decl that had an explicit default
586 -- method, mentions, rather than defines,
587 -- the default method, so we must arrange to pull it in
589 GenDefMeth -> returnM GenDefMeth
590 NoDefMeth -> returnM NoDefMeth
591 ) `thenM` \ dm_stuff' ->
593 returnM (ClassOpSig op_name dm_stuff' new_ty locn)
595 finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
596 -- Used for source file decls only
597 -- Renames the default-bindings of a class decl
598 finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
599 rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
600 -- There are some default-method bindings (abeit possibly empty) so
601 -- this is a source-code class declaration
602 = -- The newLocals call is tiresome: given a generic class decl
605 -- op {| x+y |} (Inl a) = ...
606 -- op {| x+y |} (Inr b) = ...
607 -- op {| a*b |} (a*b) = ...
608 -- we want to name both "x" tyvars with the same unique, so that they are
609 -- easy to group together in the typechecker.
612 extendTyVarEnvForMethodBinds tyvars $
613 getLocalRdrEnv `thenM` \ name_env ->
615 meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
616 gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
617 not (tv `elemRdrEnv` name_env)]
619 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_`
620 newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
621 rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) ->
622 returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
624 meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
626 finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
627 -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
628 -- This is important, because tyClDeclFVs should contain only the
629 -- FVs that are `needed' by the interface file declaration, and
630 -- derivings do not appear in this. It also means that the tcGroups
631 -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
632 = returnM (tycl_decl,
633 maybe emptyFVs extractHsCtxtTyNames derivings)
635 finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
636 -- Not a class declaration
639 For the method bindings in class and instance decls, we extend the
640 type variable environment iff -fglasgow-exts
643 extendTyVarEnvForMethodBinds tyvars thing_inside
644 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
645 if opt_GlasgowExts then
646 extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
652 %*********************************************************
654 \subsection{Support code for type/data declarations}
656 %*********************************************************
659 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
660 conDeclName (ConDecl n _ _ _ l) = (n,l)
662 rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
663 rnConDecls tycon Unknown = returnM Unknown
664 rnConDecls tycon (HasCons n) = returnM (HasCons n)
665 rnConDecls tycon (DataCons condecls)
666 = -- Check that there's at least one condecl,
667 -- or else we're reading an interface file, or -fglasgow-exts
668 (if null condecls then
669 doptM Opt_GlasgowExts `thenM` \ glaExts ->
670 getModeRn `thenM` \ mode ->
671 checkErr (glaExts || isInterfaceMode mode)
672 (emptyConDeclsErr tycon)
676 mappM rnConDecl condecls `thenM` \ condecls' ->
677 returnM (DataCons condecls')
679 rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl
680 rnConDecl (ConDecl name tvs cxt details locn)
682 checkConName name `thenM_`
683 lookupTopBndrRn name `thenM` \ new_name ->
685 bindTyVarsRn doc tvs $ \ new_tyvars ->
686 rnContext doc cxt `thenM` \ new_context ->
687 rnConDetails doc locn details `thenM` \ new_details ->
688 returnM (ConDecl new_name new_tyvars new_context new_details locn)
690 doc = text "In the definition of data constructor" <+> quotes (ppr name)
692 rnConDetails doc locn (PrefixCon tys)
693 = mappM (rnBangTy doc) tys `thenM` \ new_tys ->
694 returnM (PrefixCon new_tys)
696 rnConDetails doc locn (InfixCon ty1 ty2)
697 = rnBangTy doc ty1 `thenM` \ new_ty1 ->
698 rnBangTy doc ty2 `thenM` \ new_ty2 ->
699 returnM (InfixCon new_ty1 new_ty2)
701 rnConDetails doc locn (RecCon fields)
702 = checkDupOrQualNames doc field_names `thenM_`
703 mappM (rnField doc) fields `thenM` \ new_fields ->
704 returnM (RecCon new_fields)
706 field_names = [(fld, locn) | (fld, _) <- fields]
708 rnField doc (name, ty)
709 = lookupTopBndrRn name `thenM` \ new_name ->
710 rnBangTy doc ty `thenM` \ new_ty ->
711 returnM (new_name, new_ty)
713 rnBangTy doc (BangType s ty)
714 = rnHsType doc ty `thenM` \ new_ty ->
715 returnM (BangType s new_ty)
717 -- This data decl will parse OK
719 -- treating "a" as the constructor.
720 -- It is really hard to make the parser spot this malformation.
721 -- So the renamer has to check that the constructor is legal
723 -- We can get an operator as the constructor, even in the prefix form:
724 -- data T = :% Int Int
725 -- from interface files, which always print in prefix form
728 = checkErr (isRdrDataCon name) (badDataCon name)
732 %*********************************************************
734 \subsection{Support code to rename types}
736 %*********************************************************
739 rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]
745 = rnHsTyVars doc tys1 `thenM` \ tys1' ->
746 rnHsTyVars doc tys2 `thenM` \ tys2' ->
747 returnM (tys1', tys2')
749 rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
750 rnHsTyvar doc tyvar = lookupOccRn tyvar
753 %*********************************************************
757 %*********************************************************
760 rnIdInfo (HsWorker worker arity)
761 = lookupOccRn worker `thenM` \ worker' ->
762 returnM (HsWorker worker' arity)
764 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' ->
765 returnM (HsUnfold inline expr')
766 rnIdInfo (HsStrictness str) = returnM (HsStrictness str)
767 rnIdInfo (HsArity arity) = returnM (HsArity arity)
768 rnIdInfo HsNoCafRefs = returnM HsNoCafRefs
771 @UfCore@ expressions.
774 rnCoreExpr (UfType ty)
775 = rnHsType (text "unfolding type") ty `thenM` \ ty' ->
779 = lookupOccRn v `thenM` \ v' ->
785 rnCoreExpr (UfLitLit l ty)
786 = rnHsType (text "litlit") ty `thenM` \ ty' ->
787 returnM (UfLitLit l ty')
789 rnCoreExpr (UfFCall cc ty)
790 = rnHsType (text "ccall") ty `thenM` \ ty' ->
791 returnM (UfFCall cc ty')
793 rnCoreExpr (UfTuple (HsTupCon boxity arity) args)
794 = mappM rnCoreExpr args `thenM` \ args' ->
795 returnM (UfTuple (HsTupCon boxity arity) args')
797 rnCoreExpr (UfApp fun arg)
798 = rnCoreExpr fun `thenM` \ fun' ->
799 rnCoreExpr arg `thenM` \ arg' ->
800 returnM (UfApp fun' arg')
802 rnCoreExpr (UfCase scrut bndr alts)
803 = rnCoreExpr scrut `thenM` \ scrut' ->
804 bindCoreLocalRn bndr $ \ bndr' ->
805 mappM rnCoreAlt alts `thenM` \ alts' ->
806 returnM (UfCase scrut' bndr' alts')
808 rnCoreExpr (UfNote note expr)
809 = rnNote note `thenM` \ note' ->
810 rnCoreExpr expr `thenM` \ expr' ->
811 returnM (UfNote note' expr')
813 rnCoreExpr (UfLam bndr body)
814 = rnCoreBndr bndr $ \ bndr' ->
815 rnCoreExpr body `thenM` \ body' ->
816 returnM (UfLam bndr' body')
818 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
819 = rnCoreExpr rhs `thenM` \ rhs' ->
820 rnCoreBndr bndr $ \ bndr' ->
821 rnCoreExpr body `thenM` \ body' ->
822 returnM (UfLet (UfNonRec bndr' rhs') body')
824 rnCoreExpr (UfLet (UfRec pairs) body)
825 = rnCoreBndrs bndrs $ \ bndrs' ->
826 mappM rnCoreExpr rhss `thenM` \ rhss' ->
827 rnCoreExpr body `thenM` \ body' ->
828 returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
830 (bndrs, rhss) = unzip pairs
834 rnCoreBndr (UfValBinder name ty) thing_inside
835 = rnHsType doc ty `thenM` \ ty' ->
836 bindCoreLocalRn name $ \ name' ->
837 thing_inside (UfValBinder name' ty')
839 doc = text "unfolding id"
841 rnCoreBndr (UfTyBinder name kind) thing_inside
842 = bindCoreLocalRn name $ \ name' ->
843 thing_inside (UfTyBinder name' kind)
845 rnCoreBndrs [] thing_inside = thing_inside []
846 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
847 rnCoreBndrs bs $ \ names' ->
848 thing_inside (name':names')
852 rnCoreAlt (con, bndrs, rhs)
853 = rnUfCon con `thenM` \ con' ->
854 bindCoreLocalsRn bndrs $ \ bndrs' ->
855 rnCoreExpr rhs `thenM` \ rhs' ->
856 returnM (con', bndrs', rhs')
859 = rnHsType (text "unfolding coerce") ty `thenM` \ ty' ->
860 returnM (UfCoerce ty')
862 rnNote (UfSCC cc) = returnM (UfSCC cc)
863 rnNote UfInlineCall = returnM UfInlineCall
864 rnNote UfInlineMe = returnM UfInlineMe
870 rnUfCon (UfTupleAlt tup_con)
871 = returnM (UfTupleAlt tup_con)
873 rnUfCon (UfDataAlt con)
874 = lookupOccRn con `thenM` \ con' ->
875 returnM (UfDataAlt con')
877 rnUfCon (UfLitAlt lit)
878 = returnM (UfLitAlt lit)
880 rnUfCon (UfLitLitAlt lit ty)
881 = rnHsType (text "litlit") ty `thenM` \ ty' ->
882 returnM (UfLitLitAlt lit ty')
885 %*********************************************************
887 \subsection{Statistics}
889 %*********************************************************
892 rnStats :: [RenamedHsDecl] -- Imported decls
895 = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace ->
896 doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats ->
897 doptM Opt_D_dump_rn `thenM` \ dump_rn ->
898 getEps `thenM` \ eps ->
900 ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
902 (getRnStats eps imp_decls)) `thenM_`
905 getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
906 getRnStats eps imported_decls
907 = hcat [text "Renamer stats: ", stats]
909 n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
910 -- This is really only right for a one-shot compile
912 (decls_map, n_decls_slurped) = eps_decls eps
914 n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
915 -- Data, newtype, and class decls are in the decls_fm
916 -- under multiple names; the tycon/class, and each
917 -- constructor/class op too.
918 -- The 'True' selects just the 'main' decl
921 (insts_left, n_insts_slurped) = eps_insts eps
922 n_insts_left = length (bagToList insts_left)
924 (rules_left, n_rules_slurped) = eps_rules eps
925 n_rules_left = length (bagToList rules_left)
928 [int n_mods <+> text "interfaces read",
929 hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
930 int (n_decls_slurped + n_decls_left), text "read"],
931 hsep [ int n_insts_slurped, text "instance decls imported, out of",
932 int (n_insts_slurped + n_insts_left), text "read"],
933 hsep [ int n_rules_slurped, text "rule decls imported, out of",
934 int (n_rules_slurped + n_rules_left), text "read"]
938 %*********************************************************
942 %*********************************************************
946 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
948 badRuleLhsErr name lhs (Just bad_e)
949 = sep [ptext SLIT("Rule") <+> ftext name <> colon,
950 nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
951 ptext SLIT("in left-hand side:") <+> ppr lhs])]
953 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
956 = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
957 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
958 ptext SLIT("does not appear on left hand side")]
960 emptyConDeclsErr tycon
961 = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
962 nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]