2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
7 module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl,
8 rnSourceDecls, rnHsType, rnHsSigType
11 #include "HsVersions.h"
15 import HsTypes ( hsTyVarNames, pprHsContext )
16 import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
17 import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
18 extractRuleBndrsTyVars, extractHsTyRdrTyVars,
19 extractHsCtxtRdrTyVars, extractGenericPatTyVars
24 import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
25 import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName,
26 lookupOrigNames, lookupSysBinder, newLocalsRn,
27 bindLocalsFVRn, bindUVarRn,
28 bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
29 bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
30 checkDupOrQualNames, checkDupNames,
31 FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
36 import FunDeps ( oclose )
37 import Class ( FunDep, DefMeth (..) )
38 import Name ( Name, OccName, nameOccName, NamedThing(..) )
40 import FiniteMap ( elemFM )
41 import PrelInfo ( derivableClassKeys, cCallishClassKeys )
42 import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
43 bindIO_RDR, returnIO_RDR
45 import List ( partition, nub )
47 import SrcLoc ( SrcLoc )
48 import CmdLineOpts ( DynFlag(..) )
49 -- Warn of unused for-all'd tyvars
50 import Unique ( Uniquable(..) )
51 import ErrUtils ( Message )
52 import CStrings ( isCLabelString )
53 import ListSetOps ( removeDupsEq )
56 @rnDecl@ `renames' declarations.
57 It simultaneously performs dependency analysis and precedence parsing.
58 It also does the following error checks:
61 Checks that tyvars are used properly. This includes checking
62 for undefined tyvars, and tyvars in contexts that are ambiguous.
63 (Some of this checking has now been moved to module @TcMonoType@,
64 since we don't have functional dependency information at this point.)
66 Checks that all variable occurences are defined.
68 Checks the @(..)@ etc constraints in the export list.
72 %*********************************************************
74 \subsection{Value declarations}
76 %*********************************************************
79 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
80 -- The decls get reversed, but that's ok
83 = go emptyFVs [] decls
85 -- Fixity and deprecations have been dealt with already; ignore them
86 go fvs ds' [] = returnRn (ds', fvs)
87 go fvs ds' (FixD _:ds) = go fvs ds' ds
88 go fvs ds' (DeprecD _:ds) = go fvs ds' ds
89 go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
90 go (fvs `plusFV` fvs') (d':ds') ds
94 %*********************************************************
96 \subsection{Value declarations}
98 %*********************************************************
101 -- rnDecl does all the work
102 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
104 rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
105 returnRn (ValD new_binds, fvs)
107 rnDecl (TyClD tycl_decl) = rnTyClDecl tycl_decl `thenRn` \ (new_decl, fvs) ->
108 returnRn (TyClD new_decl, fvs)
111 = rnRuleDecl rule `thenRn` \ (new_rule, fvs) ->
112 returnRn (RuleD new_rule, fvs)
115 = rnInstDecl inst `thenRn` \ (new_inst, fvs) ->
116 returnRn (InstD new_inst, fvs)
118 rnDecl (DefD (DefaultDecl tys src_loc))
119 = pushSrcLocRn src_loc $
120 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
121 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
123 doc_str = text "a `default' declaration"
125 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
126 = pushSrcLocRn src_loc $
127 lookupOccRn name `thenRn` \ name' ->
130 | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
131 bindIO_RDR, returnIO_RDR]
133 lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
134 returnRn (addOneFV fvs name')
135 extra_fvs other = returnRn emptyFVs
137 checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
139 extra_fvs imp_exp `thenRn` \ fvs1 ->
141 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
142 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
145 fo_decl_msg = ptext SLIT("a foreign declaration")
146 isDyn = isDynamicExtName ext_nm
148 ok_ext_nm Dynamic = True
149 ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
150 ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
154 %*********************************************************
156 \subsection{Instance declarations}
158 %*********************************************************
161 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
162 = pushSrcLocRn src_loc $
163 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
165 inst_tyvars = case inst_ty' of
166 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
168 -- (Slightly strangely) the forall-d tyvars scope over
169 -- the method bindings too
172 -- Rename the bindings
173 -- NB meth_names can be qualified!
174 checkDupNames meth_doc meth_names `thenRn_`
175 extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
176 rnMethodBinds [] mbinds
177 ) `thenRn` \ (mbinds', meth_fvs) ->
179 binders = collectMonoBinders mbinds'
180 binder_set = mkNameSet binders
182 -- Rename the prags and signatures.
183 -- Note that the type variables are not in scope here,
184 -- so that instance Eq a => Eq (T a) where
185 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
188 -- But the (unqualified) method names are in scope
189 bindLocalNames binders (
190 renameSigs (okInstDclSig binder_set) uprags
191 ) `thenRn` \ (new_uprags, prag_fvs) ->
193 (case maybe_dfun_rdr_name of
194 Nothing -> returnRn (Nothing, emptyFVs)
196 Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
197 returnRn (Just dfun_name, unitFV dfun_name)
198 ) `thenRn` \ (maybe_dfun_name, dfun_fv) ->
200 -- The typechecker checks that all the bindings are for the right class.
201 returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc,
202 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
204 meth_doc = text "the bindings in an instance declaration"
205 meth_names = collectLocatedMonoBinders mbinds
208 %*********************************************************
212 %*********************************************************
215 rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
216 = pushSrcLocRn src_loc $
217 lookupOccRn fn `thenRn` \ fn' ->
218 rnCoreBndrs vars $ \ vars' ->
219 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
220 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
221 returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc,
222 (fvs1 `plusFV` fvs2) `addOneFV` fn')
224 rnRuleDecl (IfaceRuleOut fn rule)
225 -- This one is used for BuiltInRules
226 -- The rule itself is already done, but the thing
227 -- to attach it to is not.
228 = lookupOccRn fn `thenRn` \ fn' ->
229 returnRn (IfaceRuleOut fn' rule, unitFV fn')
231 rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
233 pushSrcLocRn src_loc $
235 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
236 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
237 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
239 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
240 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
241 checkRn (validRuleLhs ids lhs')
242 (badRuleLhsErr rule_name lhs') `thenRn_`
244 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
246 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
247 returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc,
248 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
250 doc = text "the transformation rule" <+> ptext rule_name
251 sig_tvs = extractRuleBndrsTyVars vars
253 get_var (RuleBndr v) = v
254 get_var (RuleBndrSig v _) = v
256 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
257 rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
258 returnRn (RuleBndrSig id t', fvs)
262 %*********************************************************
264 \subsection{Type, class and iface sig declarations}
266 %*********************************************************
268 @rnTyDecl@ uses the `global name function' to create a new type
269 declaration in which local names have been replaced by their original
270 names, reporting any unknown names.
272 Renaming type variables is a pain. Because they now contain uniques,
273 it is necessary to pass in an association list which maps a parsed
274 tyvar to its @Name@ representation.
275 In some cases (type signatures of values),
276 it is even necessary to go over the type first
277 in order to get the set of tyvars used by it, make an assoc list,
278 and then go over it again to rename the tyvars!
279 However, we can also do some scoping checks at the same time.
282 rnTyClDecl (IfaceSig name ty id_infos loc)
284 lookupTopBndrRn name `thenRn` \ name' ->
285 rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
286 mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
287 returnRn (IfaceSig name' ty' id_infos' loc, fvs1 `plusFV` fvs2)
289 doc_str = text "the interface signature for" <+> quotes (ppr name)
291 rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)
292 = pushSrcLocRn src_loc $
293 lookupTopBndrRn tycon `thenRn` \ tycon' ->
294 bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
295 rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
296 checkDupOrQualNames data_doc con_names `thenRn_`
297 mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
298 lookupSysBinder gen_name1 `thenRn` \ name1' ->
299 lookupSysBinder gen_name2 `thenRn` \ name2' ->
300 rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
301 returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
302 derivings' src_loc name1' name2',
303 cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
305 data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
306 con_names = map conDeclName condecls
308 rnTyClDecl (TySynonym name tyvars ty src_loc)
309 = pushSrcLocRn src_loc $
310 doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
311 lookupTopBndrRn name `thenRn` \ name' ->
312 bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
313 rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) ->
314 returnRn (TySynonym name' tyvars' ty' src_loc, ty_fvs)
316 syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
318 -- For H98 we do *not* universally quantify on the RHS of a synonym
319 -- Silently discard context... but the tyvars in the rest won't be in scope
320 unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
321 unquantify glaExys ty = ty
323 rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc)
324 = pushSrcLocRn src_loc $
326 lookupTopBndrRn cname `thenRn` \ cname' ->
328 -- Deal with the implicit tycon and datacon name
329 -- They aren't in scope (because they aren't visible to the user)
330 -- and what we want to do is simply look them up in the cache;
331 -- we jolly well ought to get a 'hit' there!
332 -- So the 'Imported' part of this call is not relevant.
333 -- Unclean; but since these two are the only place this happens
334 -- I can't work up the energy to do it more beautifully
336 mapRn lookupSysBinder names `thenRn` \ names' ->
338 -- Tyvars scope over bindings and context
339 bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
341 -- Check the superclasses
342 rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
344 -- Check the functional dependencies
345 rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
347 -- Check the signatures
348 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
350 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
351 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
353 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
354 mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
356 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
358 renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
361 -- The newLocals call is tiresome: given a generic class decl
364 -- op {| x+y |} (Inl a) = ...
365 -- op {| x+y |} (Inr b) = ...
366 -- op {| a*b |} (a*b) = ...
367 -- we want to name both "x" tyvars with the same unique, so that they are
368 -- easy to group together in the typechecker.
370 getLocalNameEnv `thenRn` \ name_env ->
372 meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
373 gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
374 not (tv `elemFM` name_env)]
376 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
377 newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
378 rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
380 -- Typechecker is responsible for checking that we only
381 -- give default-method bindings for things in this class.
382 -- The renamer *could* check this for class decls, but can't
383 -- for instance decls.
385 returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
396 cls_doc = text "the declaration for class" <+> ppr cname
397 sig_doc = text "the signatures for class" <+> ppr cname
398 meth_doc = text "the default-methods for class" <+> ppr cname
400 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
401 = pushSrcLocRn locn $
402 lookupTopBndrRn op `thenRn` \ op_name ->
404 -- Check the signature
405 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
407 check_in_op_ty clas_tyvar =
408 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
409 (classTyVarNotInOpTyErr clas_tyvar sig)
411 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
413 -- Make the default-method name
414 (case maybe_dm_stuff of
415 Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl
417 Just (DefMeth dm_rdr_name)
418 -> -- Imported class that has a default method decl
419 -- See comments with tname, snames, above
420 lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
421 returnRn (Just (DefMeth dm_name), unitFV dm_name)
422 -- An imported class decl for a class decl that had an explicit default
423 -- method, mentions, rather than defines,
424 -- the default method, so we must arrange to pull it in
426 -> returnRn (Just GenDefMeth, emptyFVs)
428 -> returnRn (Just NoDefMeth, emptyFVs)
429 ) `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
431 returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)
435 %*********************************************************
437 \subsection{Support code for type/data declarations}
439 %*********************************************************
442 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
444 rnDerivs Nothing -- derivs not specified
445 = returnRn (Nothing, emptyFVs)
448 = mapRn do_one clss `thenRn` \ clss' ->
449 returnRn (Just clss', mkNameSet clss')
451 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
452 checkRn (getUnique clas_name `elem` derivableClassKeys)
453 (derivingNonStdClassErr clas_name) `thenRn_`
458 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
459 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
461 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
462 rnConDecl (ConDecl name wkr tvs cxt details locn)
463 = pushSrcLocRn locn $
464 checkConName name `thenRn_`
465 lookupTopBndrRn name `thenRn` \ new_name ->
467 lookupSysBinder wkr `thenRn` \ new_wkr ->
468 -- See comments with ClassDecl
470 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
471 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
472 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
473 returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
474 cxt_fvs `plusFV` det_fvs)
476 doc = text "the definition of data constructor" <+> quotes (ppr name)
478 rnConDetails doc locn (VanillaCon tys)
479 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
480 returnRn (VanillaCon new_tys, fvs)
482 rnConDetails doc locn (InfixCon ty1 ty2)
483 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
484 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
485 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
487 rnConDetails doc locn (RecCon fields)
488 = checkDupOrQualNames doc field_names `thenRn_`
489 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
490 returnRn (RecCon new_fields, fvs)
492 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
494 rnField doc (names, ty)
495 = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
496 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
497 returnRn ((new_names, new_ty), fvs)
499 rnBangTy doc (Banged ty)
500 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
501 returnRn (Banged new_ty, fvs)
503 rnBangTy doc (Unbanged ty)
504 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
505 returnRn (Unbanged new_ty, fvs)
507 rnBangTy doc (Unpacked ty)
508 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
509 returnRn (Unpacked new_ty, fvs)
511 -- This data decl will parse OK
513 -- treating "a" as the constructor.
514 -- It is really hard to make the parser spot this malformation.
515 -- So the renamer has to check that the constructor is legal
517 -- We can get an operator as the constructor, even in the prefix form:
518 -- data T = :% Int Int
519 -- from interface files, which always print in prefix form
522 = checkRn (isRdrDataCon name)
527 %*********************************************************
529 \subsection{Support code to rename types}
531 %*********************************************************
534 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
535 -- rnHsSigType is used for source-language type signatures,
536 -- which use *implicit* universal quantification.
537 rnHsSigType doc_str ty
538 = rnHsType (text "the type signature for" <+> doc_str) ty
540 ---------------------------------------
541 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
543 rnHsType doc (HsForAllTy Nothing ctxt ty)
544 -- Implicit quantifiction in source code (no kinds on tyvars)
545 -- Given the signature C => T we universally quantify
546 -- over FV(T) \ {in-scope-tyvars}
547 = getLocalNameEnv `thenRn` \ name_env ->
549 mentioned_in_tau = extractHsTyRdrTyVars ty
550 mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
551 mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
552 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned
554 rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
556 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
557 -- Explicit quantification.
558 -- Check that the forall'd tyvars are actually
559 -- mentioned in the type, and produce a warning if not
561 mentioned_in_tau = extractHsTyRdrTyVars tau
562 mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
563 mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
564 forall_tyvar_names = hsTyVarNames forall_tyvars
566 -- Explicitly quantified but not mentioned in ctxt or tau
567 warn_guys = filter (`notElem` mentioned) forall_tyvar_names
569 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
570 rnForAll doc forall_tyvars ctxt tau
572 rnHsType doc (HsTyVar tyvar)
573 = lookupOccRn tyvar `thenRn` \ tyvar' ->
574 returnRn (HsTyVar tyvar', unitFV tyvar')
576 rnHsType doc (HsOpTy ty1 opname ty2)
577 = lookupOccRn opname `thenRn` \ name' ->
578 rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
579 rnHsType doc ty2 `thenRn` \ (ty2',fvs2) ->
580 returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name')
582 rnHsType doc (HsNumTy i)
583 | i == 1 = returnRn (HsNumTy i, emptyFVs)
584 | otherwise = failWithRn (HsNumTy i, emptyFVs)
585 (ptext SLIT("Only unit numeric type pattern is valid"))
587 rnHsType doc (HsFunTy ty1 ty2)
588 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
589 -- Might find a for-all as the arg of a function type
590 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
591 -- Or as the result. This happens when reading Prelude.hi
592 -- when we find return :: forall m. Monad m -> forall a. a -> m a
593 returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
595 rnHsType doc (HsListTy ty)
596 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
597 returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
599 -- Unboxed tuples are allowed to have poly-typed arguments. These
600 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
601 rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
602 -- Don't do lookupOccRn, because this is built-in syntax
603 -- so it doesn't need to be in scope
604 = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) ->
605 returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
607 n' = tupleTyCon_name boxity (length tys)
610 rnHsType doc (HsAppTy ty1 ty2)
611 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
612 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
613 returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
615 rnHsType doc (HsPredTy pred)
616 = rnPred doc pred `thenRn` \ (pred', fvs) ->
617 returnRn (HsPredTy pred', fvs)
619 rnHsType doc (HsUsgForAllTy uv_rdr ty)
620 = bindUVarRn doc uv_rdr $ \ uv_name ->
621 rnHsType doc ty `thenRn` \ (ty', fvs) ->
622 returnRn (HsUsgForAllTy uv_name ty',
625 rnHsType doc (HsUsgTy usg ty)
626 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
627 rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
628 -- A for-all can occur inside a usage annotation
629 returnRn (HsUsgTy usg' ty',
630 usg_fvs `plusFV` ty_fvs)
632 newUsg usg = case usg of
633 HsUsOnce -> returnRn (HsUsOnce, emptyFVs)
634 HsUsMany -> returnRn (HsUsMany, emptyFVs)
635 HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
636 returnRn (HsUsVar uv_name, emptyFVs)
638 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
642 -- We use lookupOcc here because this is interface file only stuff
643 -- and we need the workers...
644 rnHsTupCon (HsTupCon n boxity)
645 = lookupOccRn n `thenRn` \ n' ->
646 returnRn (HsTupCon n' boxity, unitFV n')
648 rnHsTupConWkr (HsTupCon n boxity)
649 -- Tuple construtors are for the *worker* of the tuple
650 -- Going direct saves needless messing about
651 = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
652 returnRn (HsTupCon n' boxity, unitFV n')
656 rnForAll doc forall_tyvars ctxt ty
657 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
658 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
659 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
660 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
661 cxt_fvs `plusFV` ty_fvs)
665 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
667 = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) ->
669 (_, dups) = removeDupsEq theta
670 -- We only have equality, not ordering
672 -- Check for duplicate assertions
673 -- If this isn't an error, then it ought to be:
674 mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_`
675 returnRn (theta, plusFVs fvs_s)
677 --Someone discovered that @CCallable@ and @CReturnable@
678 -- could be used in contexts such as:
679 -- foo :: CCallable a => a -> PrimIO Int
680 -- Doing this utterly wrecks the whole point of introducing these
681 -- classes so we specifically check that this isn't being done.
682 rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)->
683 checkRn (not (bad_pred pred'))
684 (naughtyCCallContextErr pred') `thenRn_`
685 returnRn (pred', fvs)
687 bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
688 bad_pred other = False
691 rnPred doc (HsPClass clas tys)
692 = lookupOccRn clas `thenRn` \ clas_name ->
693 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
694 returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
696 rnPred doc (HsPIParam n ty)
697 = newIPName n `thenRn` \ name ->
698 rnHsType doc ty `thenRn` \ (ty', fvs) ->
699 returnRn (HsPIParam name ty', fvs)
703 rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
706 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
707 returnRn (theta, plusFVs fvs_s)
710 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
711 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
712 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
714 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
716 = lookupOccRn tyvar `thenRn` \ tyvar' ->
717 returnRn (tyvar', unitFV tyvar')
720 %*********************************************************
724 %*********************************************************
727 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
729 rnIdInfo (HsWorker worker)
730 = lookupOccRn worker `thenRn` \ worker' ->
731 returnRn (HsWorker worker', unitFV worker')
733 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
734 returnRn (HsUnfold inline expr', fvs)
735 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
736 rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
737 rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
741 @UfCore@ expressions.
744 rnCoreExpr (UfType ty)
745 = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
746 returnRn (UfType ty', fvs)
749 = lookupOccRn v `thenRn` \ v' ->
750 returnRn (UfVar v', unitFV v')
753 = returnRn (UfLit l, emptyFVs)
755 rnCoreExpr (UfLitLit l ty)
756 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
757 returnRn (UfLitLit l ty', fvs)
759 rnCoreExpr (UfCCall cc ty)
760 = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) ->
761 returnRn (UfCCall cc ty', fvs)
763 rnCoreExpr (UfTuple con args)
764 = rnHsTupConWkr con `thenRn` \ (con', fvs1) ->
765 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
766 returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
768 rnCoreExpr (UfApp fun arg)
769 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
770 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
771 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
773 rnCoreExpr (UfCase scrut bndr alts)
774 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
775 bindCoreLocalFVRn bndr ( \ bndr' ->
776 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
777 returnRn (UfCase scrut' bndr' alts', fvs2)
778 ) `thenRn` \ (case', fvs3) ->
779 returnRn (case', fvs1 `plusFV` fvs3)
781 rnCoreExpr (UfNote note expr)
782 = rnNote note `thenRn` \ (note', fvs1) ->
783 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
784 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
786 rnCoreExpr (UfLam bndr body)
787 = rnCoreBndr bndr $ \ bndr' ->
788 rnCoreExpr body `thenRn` \ (body', fvs) ->
789 returnRn (UfLam bndr' body', fvs)
791 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
792 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
793 rnCoreBndr bndr ( \ bndr' ->
794 rnCoreExpr body `thenRn` \ (body', fvs2) ->
795 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
796 ) `thenRn` \ (result, fvs3) ->
797 returnRn (result, fvs1 `plusFV` fvs3)
799 rnCoreExpr (UfLet (UfRec pairs) body)
800 = rnCoreBndrs bndrs $ \ bndrs' ->
801 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
802 rnCoreExpr body `thenRn` \ (body', fvs2) ->
803 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
805 (bndrs, rhss) = unzip pairs
809 rnCoreBndr (UfValBinder name ty) thing_inside
810 = rnHsType doc ty `thenRn` \ (ty', fvs1) ->
811 bindCoreLocalFVRn name ( \ name' ->
812 thing_inside (UfValBinder name' ty')
813 ) `thenRn` \ (result, fvs2) ->
814 returnRn (result, fvs1 `plusFV` fvs2)
816 doc = text "unfolding id"
818 rnCoreBndr (UfTyBinder name kind) thing_inside
819 = bindCoreLocalFVRn name $ \ name' ->
820 thing_inside (UfTyBinder name' kind)
822 rnCoreBndrs [] thing_inside = thing_inside []
823 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
824 rnCoreBndrs bs $ \ names' ->
825 thing_inside (name':names')
829 rnCoreAlt (con, bndrs, rhs)
830 = rnUfCon con bndrs `thenRn` \ (con', fvs1) ->
831 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
832 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
833 returnRn ((con', bndrs', rhs'), fvs2)
834 ) `thenRn` \ (result, fvs3) ->
835 returnRn (result, fvs1 `plusFV` fvs3)
838 = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
839 returnRn (UfCoerce ty', fvs)
841 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
842 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
843 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
847 = returnRn (UfDefault, emptyFVs)
849 rnUfCon (UfTupleAlt tup_con) bndrs
850 = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) ->
851 returnRn (UfDataAlt con', fvs)
852 -- Makes the type checker a little easier
854 rnUfCon (UfDataAlt con) _
855 = lookupOccRn con `thenRn` \ con' ->
856 returnRn (UfDataAlt con', unitFV con')
858 rnUfCon (UfLitAlt lit) _
859 = returnRn (UfLitAlt lit, emptyFVs)
861 rnUfCon (UfLitLitAlt lit ty) _
862 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
863 returnRn (UfLitLitAlt lit ty', fvs)
866 %*********************************************************
868 \subsection{Rule shapes}
870 %*********************************************************
872 Check the shape of a transformation rule LHS. Currently
873 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
874 not one of the @forall@'d variables.
877 validRuleLhs foralls lhs
880 check (HsApp e1 e2) = check e1
881 check (HsVar v) | v `notElem` foralls = True
886 %*********************************************************
890 %*********************************************************
893 derivingNonStdClassErr clas
894 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
896 classTyVarNotInOpTyErr clas_tyvar sig
897 = hang (hsep [ptext SLIT("Class type variable"),
898 quotes (ppr clas_tyvar),
899 ptext SLIT("does not appear in method signature")])
903 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
905 forAllWarn doc ty tyvar
906 = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
907 () | not warn_unused -> returnRn ()
909 -> getModeRn `thenRn` \ mode ->
912 InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
913 -- unless DEBUG is on, in which case it is slightly
914 -- informative. They can arise from mkRhsTyLam,
915 #endif -- leading to (say) f :: forall a b. [b] -> [b]
918 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
919 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
921 (ptext SLIT("In") <+> doc)
925 badRuleLhsErr name lhs
926 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
927 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
929 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
932 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
933 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
934 ptext SLIT("does not appear on left hand side")]
936 badExtName :: ExtName -> Message
938 = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
940 dupClassAssertWarn ctxt (assertion : dups)
941 = sep [hsep [ptext SLIT("Duplicate class assertion"),
942 quotes (ppr assertion),
943 ptext SLIT("in the context:")],
944 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
946 naughtyCCallContextErr (HsPClass clas _)
947 = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
948 ptext SLIT("in a context")]