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,
13 #include "HsVersions.h"
17 import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
18 import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl,
19 RdrNameDeprecation, RdrNameFixitySig,
21 extractGenericPatTyVars
26 import RnNames ( importsFromLocalDecls )
27 import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
29 import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
30 renameSigs, renameSigsFVs )
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 )
61 import Maybe ( maybe, catMaybes )
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 -- Rename remaining declarations
103 (rn_src_decls, src_fvs) <- rn_src_decls decls ;
105 tcg_env <- getGblEnv ;
106 return (tcg_env, rn_src_decls, src_fvs)
109 rnExtCoreDecls :: [RdrNameHsDecl] -> RnM ([RenamedHsDecl], FreeVars)
110 rnExtCoreDecls decls = rn_src_decls decls
112 rn_src_decls decls -- Declarartions get reversed, but no matter
113 = go emptyFVs [] decls
115 -- Fixity and deprecations have been dealt with already; ignore them
116 go fvs ds' [] = returnM (ds', fvs)
117 go fvs ds' (FixD _:ds) = go fvs ds' ds
118 go fvs ds' (DeprecD _:ds) = go fvs ds' ds
119 go fvs ds' (d:ds) = rnSrcDecl d `thenM` \(d', fvs') ->
120 go (fvs `plusFV` fvs') (d':ds') ds
124 %*********************************************************
126 Source-code fixity declarations
128 %*********************************************************
131 rnSrcFixityDecls :: [RdrNameHsDecl] -> TcRn m FixityEnv
132 rnSrcFixityDecls decls
133 = getGblEnv `thenM` \ gbl_env ->
134 foldlM rnFixityDecl (tcg_fix_env gbl_env)
135 fix_decls `thenM` \ fix_env ->
136 traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
139 fix_decls = foldr get_fix_sigs [] decls
141 -- Get fixities from top level decls, and from class decl sigs too
142 get_fix_sigs (FixD fix) acc = fix:acc
143 get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
144 = [sig | FixSig sig <- sigs] ++ acc
145 get_fix_sigs other_decl acc = acc
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 rnSrcDecl :: RdrNameHsDecl -> RnM (RenamedHsDecl, FreeVars)
216 rnSrcDecl (ValD binds) = rnTopBinds binds `thenM` \ (new_binds, fvs) ->
217 returnM (ValD new_binds, fvs)
219 rnSrcDecl (TyClD tycl_decl)
220 = rnTyClDecl tycl_decl `thenM` \ new_decl ->
221 finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) ->
222 returnM (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
224 rnSrcDecl (InstD inst)
225 = rnInstDecl inst `thenM` \ new_inst ->
226 finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) ->
227 returnM (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
229 rnSrcDecl (RuleD rule)
230 = rnHsRuleDecl rule `thenM` \ (new_rule, fvs) ->
231 returnM (RuleD new_rule, fvs)
233 rnSrcDecl (ForD ford)
234 = rnHsForeignDecl ford `thenM` \ (new_ford, fvs) ->
235 returnM (ForD new_ford, fvs)
237 rnSrcDecl (DefD (DefaultDecl tys src_loc))
238 = addSrcLoc src_loc $
239 mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
240 returnM (DefD (DefaultDecl tys' src_loc), fvs)
242 doc_str = text "In a `default' declaration"
245 rnSrcDecl (CoreD (CoreDecl name ty rhs loc))
247 lookupTopBndrRn name `thenM` \ name' ->
248 rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) ->
249 rnCoreExpr rhs `thenM` \ rhs' ->
250 returnM (CoreD (CoreDecl name' ty' rhs' loc),
251 ty_fvs `plusFV` ufExprFVs rhs')
253 doc_str = text "In the Core declaration for" <+> quotes (ppr name)
256 %*********************************************************
260 %*********************************************************
262 These chaps are here, rather than in TcBinds, so that there
263 is just one hi-boot file (for RnSource). rnSrcDecls is part
264 of the loop too, and it must be defined in this module.
267 rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
268 rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
269 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
270 -- The parser doesn't produce other forms
272 rnBinds :: RdrNameHsBinds
273 -> (RenamedHsBinds -> RnM (result, FreeVars))
274 -> RnM (result, FreeVars)
275 rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
276 rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
277 -- the parser doesn't produce other forms
281 %*********************************************************
283 \subsection{Foreign declarations}
285 %*********************************************************
288 rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
289 = addSrcLoc src_loc $
290 lookupTopBndrRn name `thenM` \ name' ->
291 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
292 returnM (ForeignImport name' ty' spec isDeprec src_loc,
293 fvs `plusFV` extras spec)
295 extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
296 bindIOName, returnIOName]
299 rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
300 = addSrcLoc src_loc $
301 lookupOccRn name `thenM` \ name' ->
302 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
303 returnM (ForeignExport name' ty' spec isDeprec src_loc,
304 mkFVs [bindIOName, returnIOName] `plusFV` fvs)
306 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
310 %*********************************************************
312 \subsection{Instance declarations}
314 %*********************************************************
317 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
318 -- Used for both source and interface file decls
319 = addSrcLoc src_loc $
320 rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
322 (case maybe_dfun_rdr_name of
323 Nothing -> returnM Nothing
324 Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name ->
325 returnM (Just dfun_name)
326 ) `thenM` \ maybe_dfun_name ->
328 -- The typechecker checks that all the bindings are for the right class.
329 returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
331 -- Compare finishSourceTyClDecl
332 finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
333 (InstDecl inst_ty _ _ maybe_dfun_name src_loc)
334 -- Used for both source decls only
335 = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
337 meth_doc = text "In the bindings in an instance declaration"
338 meth_names = collectLocatedMonoBinders mbinds
339 (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
340 -- (Slightly strangely) the forall-d tyvars scope over
341 -- the method bindings too
344 -- Rename the bindings
345 -- NB meth_names can be qualified!
346 checkDupNames meth_doc meth_names `thenM_`
347 extendTyVarEnvForMethodBinds inst_tyvars (
348 rnMethodBinds cls [] mbinds
349 ) `thenM` \ (mbinds', meth_fvs) ->
351 binders = collectMonoBinders mbinds'
352 binder_set = mkNameSet binders
354 -- Rename the prags and signatures.
355 -- Note that the type variables are not in scope here,
356 -- so that instance Eq a => Eq (T a) where
357 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
360 -- But the (unqualified) method names are in scope
361 bindLocalNames binders (
362 renameSigsFVs (okInstDclSig binder_set) uprags
363 ) `thenM` \ (uprags', prag_fvs) ->
365 returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
366 meth_fvs `plusFV` prag_fvs)
369 %*********************************************************
373 %*********************************************************
376 rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
377 = addSrcLoc src_loc $
378 lookupOccRn fn `thenM` \ fn' ->
379 rnCoreBndrs vars $ \ vars' ->
380 mappM rnCoreExpr args `thenM` \ args' ->
381 rnCoreExpr rhs `thenM` \ rhs' ->
382 returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
384 rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way
385 = lookupOccRn fn `thenM` \ fn' ->
386 returnM (IfaceRuleOut fn' rule)
388 rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
389 = addSrcLoc src_loc $
390 bindPatSigTyVars (collectRuleBndrSigTys vars) $
392 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
393 mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
395 rnExpr lhs `thenM` \ (lhs', fv_lhs) ->
396 rnExpr rhs `thenM` \ (rhs', fv_rhs) ->
397 checkErr (validRuleLhs ids lhs')
398 (badRuleLhsErr rule_name lhs') `thenM_`
400 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
402 mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
403 returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
404 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
406 doc = text "In the transformation rule" <+> ftext rule_name
408 get_var (RuleBndr v) = v
409 get_var (RuleBndrSig v _) = v
411 rn_var (RuleBndr v, id) = returnM (RuleBndr id, emptyFVs)
412 rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
413 returnM (RuleBndrSig id t', fvs)
416 Check the shape of a transformation rule LHS. Currently
417 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
418 not one of the @forall@'d variables.
421 validRuleLhs foralls lhs
424 check (OpApp _ op _ _) = check op
425 check (HsApp e1 e2) = check e1
426 check (HsVar v) | v `notElem` foralls = True
431 %*********************************************************
433 \subsection{Type, class and iface sig declarations}
435 %*********************************************************
437 @rnTyDecl@ uses the `global name function' to create a new type
438 declaration in which local names have been replaced by their original
439 names, reporting any unknown names.
441 Renaming type variables is a pain. Because they now contain uniques,
442 it is necessary to pass in an association list which maps a parsed
443 tyvar to its @Name@ representation.
444 In some cases (type signatures of values),
445 it is even necessary to go over the type first
446 in order to get the set of tyvars used by it, make an assoc list,
447 and then go over it again to rename the tyvars!
448 However, we can also do some scoping checks at the same time.
451 rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
453 lookupTopBndrRn name `thenM` \ name' ->
454 rnHsType doc_str ty `thenM` \ ty' ->
455 mappM rnIdInfo id_infos `thenM` \ id_infos' ->
456 returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
458 doc_str = text "In the interface signature for" <+> quotes (ppr name)
460 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
462 lookupTopBndrRn name `thenM` \ name' ->
463 returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
465 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
466 tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
467 tcdDerivs = derivs, tcdLoc = src_loc})
468 = addSrcLoc src_loc $
469 lookupTopBndrRn tycon `thenM` \ tycon' ->
470 bindTyVarsRn data_doc tyvars $ \ tyvars' ->
471 rnContext data_doc context `thenM` \ context' ->
472 rn_derivs derivs `thenM` \ derivs' ->
473 checkDupOrQualNames data_doc con_names `thenM_`
475 rnConDecls tycon' condecls `thenM` \ condecls' ->
476 returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
477 tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
478 tcdDerivs = derivs', tcdLoc = src_loc})
480 data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
481 con_names = map conDeclName (visibleDataCons condecls)
483 rn_derivs Nothing = returnM Nothing
484 rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds')
486 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
487 = addSrcLoc src_loc $
488 lookupTopBndrRn name `thenM` \ name' ->
489 bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
490 rnHsType syn_doc ty `thenM` \ ty' ->
491 returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
493 syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
495 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
496 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
498 -- Used for both source and interface file decls
499 = addSrcLoc src_loc $
501 lookupTopBndrRn cname `thenM` \ cname' ->
503 -- Tyvars scope over superclass context and method signatures
504 bindTyVarsRn cls_doc tyvars $ \ tyvars' ->
506 -- Check the superclasses
507 rnContext cls_doc context `thenM` \ context' ->
509 -- Check the functional dependencies
510 rnFds cls_doc fds `thenM` \ fds' ->
512 -- Check the signatures
513 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
515 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
516 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
518 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_`
519 mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' ->
521 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
523 renameSigs (okClsDclSig binders) non_op_sigs `thenM` \ non_ops' ->
525 -- Typechecker is responsible for checking that we only
526 -- give default-method bindings for things in this class.
527 -- The renamer *could* check this for class decls, but can't
528 -- for instance decls.
530 returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
531 tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
534 cls_doc = text "In the declaration for class" <+> ppr cname
535 sig_doc = text "In the signatures for class" <+> ppr cname
537 rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
539 lookupTopBndrRn op `thenM` \ op_name ->
541 -- Check the signature
542 rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty ->
544 -- Make the default-method name
547 -> -- Imported class that has a default method decl
548 lookupSysBndr dm_rdr_name `thenM` \ dm_name ->
549 returnM (DefMeth dm_name)
550 -- An imported class decl for a class decl that had an explicit default
551 -- method, mentions, rather than defines,
552 -- the default method, so we must arrange to pull it in
554 GenDefMeth -> returnM GenDefMeth
555 NoDefMeth -> returnM NoDefMeth
556 ) `thenM` \ dm_stuff' ->
558 returnM (ClassOpSig op_name dm_stuff' new_ty locn)
560 finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
561 -- Used for source file decls only
562 -- Renames the default-bindings of a class decl
563 finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
564 rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
565 -- There are some default-method bindings (abeit possibly empty) so
566 -- this is a source-code class declaration
567 = -- The newLocals call is tiresome: given a generic class decl
570 -- op {| x+y |} (Inl a) = ...
571 -- op {| x+y |} (Inr b) = ...
572 -- op {| a*b |} (a*b) = ...
573 -- we want to name both "x" tyvars with the same unique, so that they are
574 -- easy to group together in the typechecker.
577 extendTyVarEnvForMethodBinds tyvars $
578 getLocalRdrEnv `thenM` \ name_env ->
580 meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
581 gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
582 not (tv `elemRdrEnv` name_env)]
584 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_`
585 newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
586 rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) ->
587 returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
589 meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
591 finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
592 -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
593 -- This is important, because tyClDeclFVs should contain only the
594 -- FVs that are `needed' by the interface file declaration, and
595 -- derivings do not appear in this. It also means that the tcGroups
596 -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
597 = returnM (tycl_decl,
598 maybe emptyFVs extractHsCtxtTyNames derivings)
600 finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
601 -- Not a class declaration
604 For the method bindings in class and instance decls, we extend the
605 type variable environment iff -fglasgow-exts
608 extendTyVarEnvForMethodBinds tyvars thing_inside
609 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
610 if opt_GlasgowExts then
611 extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
617 %*********************************************************
619 \subsection{Support code for type/data declarations}
621 %*********************************************************
624 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
625 conDeclName (ConDecl n _ _ _ l) = (n,l)
627 rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
628 rnConDecls tycon Unknown = returnM Unknown
629 rnConDecls tycon (HasCons n) = returnM (HasCons n)
630 rnConDecls tycon (DataCons condecls)
631 = -- Check that there's at least one condecl,
632 -- or else we're reading an interface file, or -fglasgow-exts
633 (if null condecls then
634 doptM Opt_GlasgowExts `thenM` \ glaExts ->
635 getModeRn `thenM` \ mode ->
636 checkErr (glaExts || isInterfaceMode mode)
637 (emptyConDeclsErr tycon)
641 mappM rnConDecl condecls `thenM` \ condecls' ->
642 returnM (DataCons condecls')
644 rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl
645 rnConDecl (ConDecl name tvs cxt details locn)
647 checkConName name `thenM_`
648 lookupTopBndrRn name `thenM` \ new_name ->
650 bindTyVarsRn doc tvs $ \ new_tyvars ->
651 rnContext doc cxt `thenM` \ new_context ->
652 rnConDetails doc locn details `thenM` \ new_details ->
653 returnM (ConDecl new_name new_tyvars new_context new_details locn)
655 doc = text "In the definition of data constructor" <+> quotes (ppr name)
657 rnConDetails doc locn (PrefixCon tys)
658 = mappM (rnBangTy doc) tys `thenM` \ new_tys ->
659 returnM (PrefixCon new_tys)
661 rnConDetails doc locn (InfixCon ty1 ty2)
662 = rnBangTy doc ty1 `thenM` \ new_ty1 ->
663 rnBangTy doc ty2 `thenM` \ new_ty2 ->
664 returnM (InfixCon new_ty1 new_ty2)
666 rnConDetails doc locn (RecCon fields)
667 = checkDupOrQualNames doc field_names `thenM_`
668 mappM (rnField doc) fields `thenM` \ new_fields ->
669 returnM (RecCon new_fields)
671 field_names = [(fld, locn) | (fld, _) <- fields]
673 rnField doc (name, ty)
674 = lookupTopBndrRn name `thenM` \ new_name ->
675 rnBangTy doc ty `thenM` \ new_ty ->
676 returnM (new_name, new_ty)
678 rnBangTy doc (BangType s ty)
679 = rnHsType doc ty `thenM` \ new_ty ->
680 returnM (BangType s new_ty)
682 -- This data decl will parse OK
684 -- treating "a" as the constructor.
685 -- It is really hard to make the parser spot this malformation.
686 -- So the renamer has to check that the constructor is legal
688 -- We can get an operator as the constructor, even in the prefix form:
689 -- data T = :% Int Int
690 -- from interface files, which always print in prefix form
693 = checkErr (isRdrDataCon name) (badDataCon name)
697 %*********************************************************
699 \subsection{Support code to rename types}
701 %*********************************************************
704 rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]
710 = rnHsTyVars doc tys1 `thenM` \ tys1' ->
711 rnHsTyVars doc tys2 `thenM` \ tys2' ->
712 returnM (tys1', tys2')
714 rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
715 rnHsTyvar doc tyvar = lookupOccRn tyvar
718 %*********************************************************
722 %*********************************************************
725 rnIdInfo (HsWorker worker arity)
726 = lookupOccRn worker `thenM` \ worker' ->
727 returnM (HsWorker worker' arity)
729 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' ->
730 returnM (HsUnfold inline expr')
731 rnIdInfo (HsStrictness str) = returnM (HsStrictness str)
732 rnIdInfo (HsArity arity) = returnM (HsArity arity)
733 rnIdInfo HsNoCafRefs = returnM HsNoCafRefs
736 @UfCore@ expressions.
739 rnCoreExpr (UfType ty)
740 = rnHsType (text "unfolding type") ty `thenM` \ ty' ->
744 = lookupOccRn v `thenM` \ v' ->
750 rnCoreExpr (UfLitLit l ty)
751 = rnHsType (text "litlit") ty `thenM` \ ty' ->
752 returnM (UfLitLit l ty')
754 rnCoreExpr (UfFCall cc ty)
755 = rnHsType (text "ccall") ty `thenM` \ ty' ->
756 returnM (UfFCall cc ty')
758 rnCoreExpr (UfTuple (HsTupCon boxity arity) args)
759 = mappM rnCoreExpr args `thenM` \ args' ->
760 returnM (UfTuple (HsTupCon boxity arity) args')
762 rnCoreExpr (UfApp fun arg)
763 = rnCoreExpr fun `thenM` \ fun' ->
764 rnCoreExpr arg `thenM` \ arg' ->
765 returnM (UfApp fun' arg')
767 rnCoreExpr (UfCase scrut bndr alts)
768 = rnCoreExpr scrut `thenM` \ scrut' ->
769 bindCoreLocalRn bndr $ \ bndr' ->
770 mappM rnCoreAlt alts `thenM` \ alts' ->
771 returnM (UfCase scrut' bndr' alts')
773 rnCoreExpr (UfNote note expr)
774 = rnNote note `thenM` \ note' ->
775 rnCoreExpr expr `thenM` \ expr' ->
776 returnM (UfNote note' expr')
778 rnCoreExpr (UfLam bndr body)
779 = rnCoreBndr bndr $ \ bndr' ->
780 rnCoreExpr body `thenM` \ body' ->
781 returnM (UfLam bndr' body')
783 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
784 = rnCoreExpr rhs `thenM` \ rhs' ->
785 rnCoreBndr bndr $ \ bndr' ->
786 rnCoreExpr body `thenM` \ body' ->
787 returnM (UfLet (UfNonRec bndr' rhs') body')
789 rnCoreExpr (UfLet (UfRec pairs) body)
790 = rnCoreBndrs bndrs $ \ bndrs' ->
791 mappM rnCoreExpr rhss `thenM` \ rhss' ->
792 rnCoreExpr body `thenM` \ body' ->
793 returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
795 (bndrs, rhss) = unzip pairs
799 rnCoreBndr (UfValBinder name ty) thing_inside
800 = rnHsType doc ty `thenM` \ ty' ->
801 bindCoreLocalRn name $ \ name' ->
802 thing_inside (UfValBinder name' ty')
804 doc = text "unfolding id"
806 rnCoreBndr (UfTyBinder name kind) thing_inside
807 = bindCoreLocalRn name $ \ name' ->
808 thing_inside (UfTyBinder name' kind)
810 rnCoreBndrs [] thing_inside = thing_inside []
811 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
812 rnCoreBndrs bs $ \ names' ->
813 thing_inside (name':names')
817 rnCoreAlt (con, bndrs, rhs)
818 = rnUfCon con `thenM` \ con' ->
819 bindCoreLocalsRn bndrs $ \ bndrs' ->
820 rnCoreExpr rhs `thenM` \ rhs' ->
821 returnM (con', bndrs', rhs')
824 = rnHsType (text "unfolding coerce") ty `thenM` \ ty' ->
825 returnM (UfCoerce ty')
827 rnNote (UfSCC cc) = returnM (UfSCC cc)
828 rnNote UfInlineCall = returnM UfInlineCall
829 rnNote UfInlineMe = returnM UfInlineMe
835 rnUfCon (UfTupleAlt tup_con)
836 = returnM (UfTupleAlt tup_con)
838 rnUfCon (UfDataAlt con)
839 = lookupOccRn con `thenM` \ con' ->
840 returnM (UfDataAlt con')
842 rnUfCon (UfLitAlt lit)
843 = returnM (UfLitAlt lit)
845 rnUfCon (UfLitLitAlt lit ty)
846 = rnHsType (text "litlit") ty `thenM` \ ty' ->
847 returnM (UfLitLitAlt lit ty')
850 %*********************************************************
852 \subsection{Statistics}
854 %*********************************************************
857 rnStats :: [RenamedHsDecl] -- Imported decls
860 = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace ->
861 doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats ->
862 doptM Opt_D_dump_rn `thenM` \ dump_rn ->
863 getEps `thenM` \ eps ->
865 ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
867 (getRnStats eps imp_decls)) `thenM_`
870 getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
871 getRnStats eps imported_decls
872 = hcat [text "Renamer stats: ", stats]
874 n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
875 -- This is really only right for a one-shot compile
877 (decls_map, n_decls_slurped) = eps_decls eps
879 n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
880 -- Data, newtype, and class decls are in the decls_fm
881 -- under multiple names; the tycon/class, and each
882 -- constructor/class op too.
883 -- The 'True' selects just the 'main' decl
886 (insts_left, n_insts_slurped) = eps_insts eps
887 n_insts_left = length (bagToList insts_left)
889 (rules_left, n_rules_slurped) = eps_rules eps
890 n_rules_left = length (bagToList rules_left)
893 [int n_mods <+> text "interfaces read",
894 hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
895 int (n_decls_slurped + n_decls_left), text "read"],
896 hsep [ int n_insts_slurped, text "instance decls imported, out of",
897 int (n_insts_slurped + n_insts_left), text "read"],
898 hsep [ int n_rules_slurped, text "rule decls imported, out of",
899 int (n_rules_slurped + n_rules_left), text "read"]
903 %*********************************************************
907 %*********************************************************
911 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
913 badRuleLhsErr name lhs
914 = sep [ptext SLIT("Rule") <+> ftext name <> colon,
915 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
917 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
920 = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
921 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
922 ptext SLIT("does not appear on left hand side")]
924 emptyConDeclsErr tycon
925 = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
926 nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]