2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
7 module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
9 #include "HsVersions.h"
14 import HsTypes ( hsTyVarNames, pprHsContext )
15 import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
16 import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
17 extractRuleBndrsTyVars, extractHsTyRdrTyVars,
18 extractHsCtxtRdrTyVars, extractGenericPatTyVars
23 import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
24 import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName,
25 lookupOrigNames, lookupSysBinder, newLocalsRn,
26 bindLocalsFVRn, bindUVarRn,
27 bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
28 bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
29 checkDupOrQualNames, checkDupNames,
30 FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
35 import FunDeps ( oclose )
36 import Class ( FunDep, DefMeth (..) )
37 import Name ( Name, OccName, nameOccName, NamedThing(..) )
39 import OccName ( mkDefaultMethodOcc, isTvOcc )
40 import FiniteMap ( elemFM )
41 import PrelInfo ( derivableClassKeys, cCallishClassKeys )
42 import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
43 bindIO_RDR, returnIO_RDR
45 import Bag ( bagToList )
46 import List ( partition, nub )
48 import SrcLoc ( SrcLoc )
49 import CmdLineOpts ( DynFlags, DynFlag(..) )
50 -- Warn of unused for-all'd tyvars
51 import Unique ( Uniquable(..) )
52 import ErrUtils ( Message )
53 import CStrings ( isCLabelString )
54 import ListSetOps ( minusList, removeDupsEq )
57 @rnDecl@ `renames' declarations.
58 It simultaneously performs dependency analysis and precedence parsing.
59 It also does the following error checks:
62 Checks that tyvars are used properly. This includes checking
63 for undefined tyvars, and tyvars in contexts that are ambiguous.
64 (Some of this checking has now been moved to module @TcMonoType@,
65 since we don't have functional dependency information at this point.)
67 Checks that all variable occurences are defined.
69 Checks the @(..)@ etc constraints in the export list.
73 %*********************************************************
75 \subsection{Value declarations}
77 %*********************************************************
80 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
81 -- The decls get reversed, but that's ok
84 = go emptyFVs [] decls
86 -- Fixity and deprecations have been dealt with already; ignore them
87 go fvs ds' [] = returnRn (ds', fvs)
88 go fvs ds' (FixD _:ds) = go fvs ds' ds
89 go fvs ds' (DeprecD _:ds) = go fvs ds' ds
90 go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
91 go (fvs `plusFV` fvs') (d':ds') ds
95 %*********************************************************
97 \subsection{Value declarations}
99 %*********************************************************
102 -- rnDecl does all the work
103 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
105 rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
106 returnRn (ValD new_binds, fvs)
109 rnDecl (SigD (IfaceSig name ty id_infos loc))
111 lookupTopBndrRn name `thenRn` \ name' ->
112 rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
113 mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
114 returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
116 doc_str = text "the interface signature for" <+> quotes (ppr name)
119 %*********************************************************
121 \subsection{Type declarations}
123 %*********************************************************
125 @rnTyDecl@ uses the `global name function' to create a new type
126 declaration in which local names have been replaced by their original
127 names, reporting any unknown names.
129 Renaming type variables is a pain. Because they now contain uniques,
130 it is necessary to pass in an association list which maps a parsed
131 tyvar to its @Name@ representation.
132 In some cases (type signatures of values),
133 it is even necessary to go over the type first
134 in order to get the set of tyvars used by it, make an assoc list,
135 and then go over it again to rename the tyvars!
136 However, we can also do some scoping checks at the same time.
139 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc gen_name1 gen_name2))
140 = pushSrcLocRn src_loc $
141 lookupTopBndrRn tycon `thenRn` \ tycon' ->
142 bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
143 rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
144 checkDupOrQualNames data_doc con_names `thenRn_`
145 mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
146 lookupSysBinder gen_name1 `thenRn` \ name1' ->
147 lookupSysBinder gen_name2 `thenRn` \ name2' ->
148 rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
149 ASSERT(isNoDataPragmas pragmas)
150 returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
151 derivings' noDataPragmas src_loc name1' name2'),
152 cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
154 data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
155 con_names = map conDeclName condecls
157 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
158 = pushSrcLocRn src_loc $
159 doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
160 lookupTopBndrRn name `thenRn` \ name' ->
161 bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
162 rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) ->
163 returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
165 syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
167 -- For H98 we do *not* universally quantify on the RHS of a synonym
168 -- Silently discard context... but the tyvars in the rest won't be in scope
169 unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
170 unquantify glaExys ty = ty
172 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
174 = pushSrcLocRn src_loc $
176 lookupTopBndrRn cname `thenRn` \ cname' ->
178 -- Deal with the implicit tycon and datacon name
179 -- They aren't in scope (because they aren't visible to the user)
180 -- and what we want to do is simply look them up in the cache;
181 -- we jolly well ought to get a 'hit' there!
182 -- So the 'Imported' part of this call is not relevant.
183 -- Unclean; but since these two are the only place this happens
184 -- I can't work up the energy to do it more beautifully
186 mapRn lookupSysBinder names `thenRn` \ names' ->
188 -- Tyvars scope over bindings and context
189 bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
191 -- Check the superclasses
192 rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
194 -- Check the functional dependencies
195 rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
197 -- Check the signatures
198 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
200 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
201 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
203 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
204 mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
206 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
208 renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
211 -- The newLocals call is tiresome: given a generic class decl
214 -- op {| x+y |} (Inl a) = ...
215 -- op {| x+y |} (Inr b) = ...
216 -- op {| a*b |} (a*b) = ...
217 -- we want to name both "x" tyvars with the same unique, so that they are
218 -- easy to group together in the typechecker.
220 getLocalNameEnv `thenRn` \ name_env ->
222 meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
223 gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
224 not (tv `elemFM` name_env)]
226 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
227 newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
228 rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
230 -- Typechecker is responsible for checking that we only
231 -- give default-method bindings for things in this class.
232 -- The renamer *could* check this for class decls, but can't
233 -- for instance decls.
235 ASSERT(isNoClassPragmas pragmas)
236 returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
237 NoClassPragmas names' src_loc),
247 cls_doc = text "the declaration for class" <+> ppr cname
248 sig_doc = text "the signatures for class" <+> ppr cname
249 meth_doc = text "the default-methods for class" <+> ppr cname
251 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
252 = pushSrcLocRn locn $
253 lookupTopBndrRn op `thenRn` \ op_name ->
255 -- Check the signature
256 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
258 check_in_op_ty clas_tyvar =
259 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
260 (classTyVarNotInOpTyErr clas_tyvar sig)
262 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
264 -- Make the default-method name
265 (case maybe_dm_stuff of
266 Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl
268 Just (DefMeth dm_rdr_name)
269 -> -- Imported class that has a default method decl
270 -- See comments with tname, snames, above
271 lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
272 returnRn (Just (DefMeth dm_name), unitFV dm_name)
273 -- An imported class decl for a class decl that had an explicit default
274 -- method, mentions, rather than defines,
275 -- the default method, so we must arrange to pull it in
277 -> returnRn (Just GenDefMeth, emptyFVs)
279 -> returnRn (Just NoDefMeth, emptyFVs)
280 ) `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
282 returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)
286 %*********************************************************
288 \subsection{Instance declarations}
290 %*********************************************************
293 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc))
294 = pushSrcLocRn src_loc $
295 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
297 inst_tyvars = case inst_ty' of
298 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
300 -- (Slightly strangely) the forall-d tyvars scope over
301 -- the method bindings too
304 -- Rename the bindings
305 -- NB meth_names can be qualified!
306 checkDupNames meth_doc meth_names `thenRn_`
307 extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
308 rnMethodBinds [] mbinds
309 ) `thenRn` \ (mbinds', meth_fvs) ->
311 binders = collectMonoBinders mbinds'
312 binder_set = mkNameSet binders
314 -- Rename the prags and signatures.
315 -- Note that the type variables are not in scope here,
316 -- so that instance Eq a => Eq (T a) where
317 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
320 -- But the (unqualified) method names are in scope
321 bindLocalNames binders (
322 renameSigs (okInstDclSig binder_set) uprags
323 ) `thenRn` \ (new_uprags, prag_fvs) ->
325 (case maybe_dfun_rdr_name of
326 Nothing -> returnRn (Nothing, emptyFVs)
328 Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
329 returnRn (Just dfun_name, unitFV dfun_name)
330 ) `thenRn` \ (maybe_dfun_name, dfun_fv) ->
332 -- The typechecker checks that all the bindings are for the right class.
333 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc),
334 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
336 meth_doc = text "the bindings in an instance declaration"
337 meth_names = collectLocatedMonoBinders mbinds
340 %*********************************************************
342 \subsection{Default declarations}
344 %*********************************************************
347 rnDecl (DefD (DefaultDecl tys src_loc))
348 = pushSrcLocRn src_loc $
349 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
350 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
352 doc_str = text "a `default' declaration"
355 %*********************************************************
357 \subsection{Foreign declarations}
359 %*********************************************************
362 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
363 = pushSrcLocRn src_loc $
364 lookupOccRn name `thenRn` \ name' ->
367 | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
368 bindIO_RDR, returnIO_RDR]
370 lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
371 returnRn (addOneFV fvs name')
372 extra_fvs other = returnRn emptyFVs
374 checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
376 extra_fvs imp_exp `thenRn` \ fvs1 ->
378 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
379 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
382 fo_decl_msg = ptext SLIT("a foreign declaration")
383 isDyn = isDynamicExtName ext_nm
385 ok_ext_nm Dynamic = True
386 ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
387 ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
390 %*********************************************************
394 %*********************************************************
397 rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc))
398 = pushSrcLocRn src_loc $
399 lookupOccRn fn `thenRn` \ fn' ->
400 rnCoreBndrs vars $ \ vars' ->
401 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
402 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
403 returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc),
404 (fvs1 `plusFV` fvs2) `addOneFV` fn')
406 rnDecl (RuleD (IfaceRuleOut fn rule))
407 -- This one is used for BuiltInRules
408 -- The rule itself is already done, but the thing
409 -- to attach it to is not.
410 = lookupOccRn fn `thenRn` \ fn' ->
411 returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
413 rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
415 pushSrcLocRn src_loc $
417 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
418 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
419 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
421 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
422 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
423 checkRn (validRuleLhs ids lhs')
424 (badRuleLhsErr rule_name lhs') `thenRn_`
426 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
428 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
429 returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc),
430 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
432 doc = text "the transformation rule" <+> ptext rule_name
433 sig_tvs = extractRuleBndrsTyVars vars
435 get_var (RuleBndr v) = v
436 get_var (RuleBndrSig v _) = v
438 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
439 rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
440 returnRn (RuleBndrSig id t', fvs)
444 %*********************************************************
446 \subsection{Support code for type/data declarations}
448 %*********************************************************
451 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
453 rnDerivs Nothing -- derivs not specified
454 = returnRn (Nothing, emptyFVs)
457 = mapRn do_one clss `thenRn` \ clss' ->
458 returnRn (Just clss', mkNameSet clss')
460 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
461 checkRn (getUnique clas_name `elem` derivableClassKeys)
462 (derivingNonStdClassErr clas_name) `thenRn_`
467 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
468 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
470 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
471 rnConDecl (ConDecl name wkr tvs cxt details locn)
472 = pushSrcLocRn locn $
473 checkConName name `thenRn_`
474 lookupTopBndrRn name `thenRn` \ new_name ->
476 lookupSysBinder wkr `thenRn` \ new_wkr ->
477 -- See comments with ClassDecl
479 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
480 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
481 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
482 returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
483 cxt_fvs `plusFV` det_fvs)
485 doc = text "the definition of data constructor" <+> quotes (ppr name)
487 rnConDetails doc locn (VanillaCon tys)
488 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
489 returnRn (VanillaCon new_tys, fvs)
491 rnConDetails doc locn (InfixCon ty1 ty2)
492 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
493 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
494 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
496 rnConDetails doc locn (RecCon fields)
497 = checkDupOrQualNames doc field_names `thenRn_`
498 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
499 returnRn (RecCon new_fields, fvs)
501 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
503 rnField doc (names, ty)
504 = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
505 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
506 returnRn ((new_names, new_ty), fvs)
508 rnBangTy doc (Banged ty)
509 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
510 returnRn (Banged new_ty, fvs)
512 rnBangTy doc (Unbanged ty)
513 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
514 returnRn (Unbanged new_ty, fvs)
516 rnBangTy doc (Unpacked ty)
517 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
518 returnRn (Unpacked new_ty, fvs)
520 -- This data decl will parse OK
522 -- treating "a" as the constructor.
523 -- It is really hard to make the parser spot this malformation.
524 -- So the renamer has to check that the constructor is legal
526 -- We can get an operator as the constructor, even in the prefix form:
527 -- data T = :% Int Int
528 -- from interface files, which always print in prefix form
531 = checkRn (isRdrDataCon name)
536 %*********************************************************
538 \subsection{Support code to rename types}
540 %*********************************************************
543 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
544 -- rnHsSigType is used for source-language type signatures,
545 -- which use *implicit* universal quantification.
546 rnHsSigType doc_str ty
547 = rnHsType (text "the type signature for" <+> doc_str) ty
549 ---------------------------------------
550 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
552 rnHsType doc (HsForAllTy Nothing ctxt ty)
553 -- Implicit quantifiction in source code (no kinds on tyvars)
554 -- Given the signature C => T we universally quantify
555 -- over FV(T) \ {in-scope-tyvars}
556 = getLocalNameEnv `thenRn` \ name_env ->
558 mentioned_in_tau = extractHsTyRdrTyVars ty
559 mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
560 mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
561 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned
563 rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
565 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
566 -- Explicit quantification.
567 -- Check that the forall'd tyvars are actually
568 -- mentioned in the type, and produce a warning if not
570 mentioned_in_tau = extractHsTyRdrTyVars tau
571 mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
572 mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
573 forall_tyvar_names = hsTyVarNames forall_tyvars
575 -- Explicitly quantified but not mentioned in ctxt or tau
576 warn_guys = filter (`notElem` mentioned) forall_tyvar_names
578 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
579 rnForAll doc forall_tyvars ctxt tau
581 rnHsType doc (HsTyVar tyvar)
582 = lookupOccRn tyvar `thenRn` \ tyvar' ->
583 returnRn (HsTyVar tyvar', unitFV tyvar')
585 rnHsType doc (HsOpTy ty1 opname ty2)
586 = lookupOccRn opname `thenRn` \ name' ->
587 rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
588 rnHsType doc ty2 `thenRn` \ (ty2',fvs2) ->
589 returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name')
591 rnHsType doc (HsNumTy i)
592 | i == 1 = returnRn (HsNumTy i, emptyFVs)
593 | otherwise = failWithRn (HsNumTy i, emptyFVs)
594 (ptext SLIT("Only unit numeric type pattern is valid"))
596 rnHsType doc (HsFunTy ty1 ty2)
597 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
598 -- Might find a for-all as the arg of a function type
599 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
600 -- Or as the result. This happens when reading Prelude.hi
601 -- when we find return :: forall m. Monad m -> forall a. a -> m a
602 returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
604 rnHsType doc (HsListTy ty)
605 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
606 returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
608 -- Unboxed tuples are allowed to have poly-typed arguments. These
609 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
610 rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
611 -- Don't do lookupOccRn, because this is built-in syntax
612 -- so it doesn't need to be in scope
613 = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) ->
614 returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
616 n' = tupleTyCon_name boxity (length tys)
619 rnHsType doc (HsAppTy ty1 ty2)
620 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
621 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
622 returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
624 rnHsType doc (HsPredTy pred)
625 = rnPred doc pred `thenRn` \ (pred', fvs) ->
626 returnRn (HsPredTy pred', fvs)
628 rnHsType doc (HsUsgForAllTy uv_rdr ty)
629 = bindUVarRn doc uv_rdr $ \ uv_name ->
630 rnHsType doc ty `thenRn` \ (ty', fvs) ->
631 returnRn (HsUsgForAllTy uv_name ty',
634 rnHsType doc (HsUsgTy usg ty)
635 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
636 rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
637 -- A for-all can occur inside a usage annotation
638 returnRn (HsUsgTy usg' ty',
639 usg_fvs `plusFV` ty_fvs)
641 newUsg usg = case usg of
642 HsUsOnce -> returnRn (HsUsOnce, emptyFVs)
643 HsUsMany -> returnRn (HsUsMany, emptyFVs)
644 HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
645 returnRn (HsUsVar uv_name, emptyFVs)
647 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
651 -- We use lookupOcc here because this is interface file only stuff
652 -- and we need the workers...
653 rnHsTupCon (HsTupCon n boxity)
654 = lookupOccRn n `thenRn` \ n' ->
655 returnRn (HsTupCon n' boxity, unitFV n')
657 rnHsTupConWkr (HsTupCon n boxity)
658 -- Tuple construtors are for the *worker* of the tuple
659 -- Going direct saves needless messing about
660 = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
661 returnRn (HsTupCon n' boxity, unitFV n')
665 rnForAll doc forall_tyvars ctxt ty
666 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
667 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
668 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
669 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
670 cxt_fvs `plusFV` ty_fvs)
674 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
676 = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) ->
678 (_, dups) = removeDupsEq theta
679 -- We only have equality, not ordering
681 -- Check for duplicate assertions
682 -- If this isn't an error, then it ought to be:
683 mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_`
684 returnRn (theta, plusFVs fvs_s)
686 --Someone discovered that @CCallable@ and @CReturnable@
687 -- could be used in contexts such as:
688 -- foo :: CCallable a => a -> PrimIO Int
689 -- Doing this utterly wrecks the whole point of introducing these
690 -- classes so we specifically check that this isn't being done.
691 rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)->
692 checkRn (not (bad_pred pred'))
693 (naughtyCCallContextErr pred') `thenRn_`
694 returnRn (pred', fvs)
696 bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
697 bad_pred other = False
700 rnPred doc (HsPClass clas tys)
701 = lookupOccRn clas `thenRn` \ clas_name ->
702 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
703 returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
705 rnPred doc (HsPIParam n ty)
706 = newIPName n `thenRn` \ name ->
707 rnHsType doc ty `thenRn` \ (ty', fvs) ->
708 returnRn (HsPIParam name ty', fvs)
712 rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
715 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
716 returnRn (theta, plusFVs fvs_s)
719 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
720 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
721 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
723 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
725 = lookupOccRn tyvar `thenRn` \ tyvar' ->
726 returnRn (tyvar', unitFV tyvar')
729 %*********************************************************
733 %*********************************************************
736 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
738 rnIdInfo (HsWorker worker)
739 = lookupOccRn worker `thenRn` \ worker' ->
740 returnRn (HsWorker worker', unitFV worker')
742 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
743 returnRn (HsUnfold inline expr', fvs)
744 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
745 rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
746 rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
750 @UfCore@ expressions.
753 rnCoreExpr (UfType ty)
754 = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
755 returnRn (UfType ty', fvs)
758 = lookupOccRn v `thenRn` \ v' ->
759 returnRn (UfVar v', unitFV v')
762 = returnRn (UfLit l, emptyFVs)
764 rnCoreExpr (UfLitLit l ty)
765 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
766 returnRn (UfLitLit l ty', fvs)
768 rnCoreExpr (UfCCall cc ty)
769 = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) ->
770 returnRn (UfCCall cc ty', fvs)
772 rnCoreExpr (UfTuple con args)
773 = rnHsTupConWkr con `thenRn` \ (con', fvs1) ->
774 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
775 returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
777 rnCoreExpr (UfApp fun arg)
778 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
779 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
780 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
782 rnCoreExpr (UfCase scrut bndr alts)
783 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
784 bindCoreLocalFVRn bndr ( \ bndr' ->
785 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
786 returnRn (UfCase scrut' bndr' alts', fvs2)
787 ) `thenRn` \ (case', fvs3) ->
788 returnRn (case', fvs1 `plusFV` fvs3)
790 rnCoreExpr (UfNote note expr)
791 = rnNote note `thenRn` \ (note', fvs1) ->
792 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
793 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
795 rnCoreExpr (UfLam bndr body)
796 = rnCoreBndr bndr $ \ bndr' ->
797 rnCoreExpr body `thenRn` \ (body', fvs) ->
798 returnRn (UfLam bndr' body', fvs)
800 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
801 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
802 rnCoreBndr bndr ( \ bndr' ->
803 rnCoreExpr body `thenRn` \ (body', fvs2) ->
804 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
805 ) `thenRn` \ (result, fvs3) ->
806 returnRn (result, fvs1 `plusFV` fvs3)
808 rnCoreExpr (UfLet (UfRec pairs) body)
809 = rnCoreBndrs bndrs $ \ bndrs' ->
810 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
811 rnCoreExpr body `thenRn` \ (body', fvs2) ->
812 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
814 (bndrs, rhss) = unzip pairs
818 rnCoreBndr (UfValBinder name ty) thing_inside
819 = rnHsType doc ty `thenRn` \ (ty', fvs1) ->
820 bindCoreLocalFVRn name ( \ name' ->
821 thing_inside (UfValBinder name' ty')
822 ) `thenRn` \ (result, fvs2) ->
823 returnRn (result, fvs1 `plusFV` fvs2)
825 doc = text "unfolding id"
827 rnCoreBndr (UfTyBinder name kind) thing_inside
828 = bindCoreLocalFVRn name $ \ name' ->
829 thing_inside (UfTyBinder name' kind)
831 rnCoreBndrs [] thing_inside = thing_inside []
832 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
833 rnCoreBndrs bs $ \ names' ->
834 thing_inside (name':names')
838 rnCoreAlt (con, bndrs, rhs)
839 = rnUfCon con bndrs `thenRn` \ (con', fvs1) ->
840 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
841 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
842 returnRn ((con', bndrs', rhs'), fvs2)
843 ) `thenRn` \ (result, fvs3) ->
844 returnRn (result, fvs1 `plusFV` fvs3)
847 = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
848 returnRn (UfCoerce ty', fvs)
850 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
851 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
852 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
856 = returnRn (UfDefault, emptyFVs)
858 rnUfCon (UfTupleAlt tup_con) bndrs
859 = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) ->
860 returnRn (UfDataAlt con', fvs)
861 -- Makes the type checker a little easier
863 rnUfCon (UfDataAlt con) _
864 = lookupOccRn con `thenRn` \ con' ->
865 returnRn (UfDataAlt con', unitFV con')
867 rnUfCon (UfLitAlt lit) _
868 = returnRn (UfLitAlt lit, emptyFVs)
870 rnUfCon (UfLitLitAlt lit ty) _
871 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
872 returnRn (UfLitLitAlt lit ty', fvs)
875 %*********************************************************
877 \subsection{Rule shapes}
879 %*********************************************************
881 Check the shape of a transformation rule LHS. Currently
882 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
883 not one of the @forall@'d variables.
886 validRuleLhs foralls lhs
889 check (HsApp e1 e2) = check e1
890 check (HsVar v) | v `notElem` foralls = True
895 %*********************************************************
899 %*********************************************************
902 derivingNonStdClassErr clas
903 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
905 classTyVarNotInOpTyErr clas_tyvar sig
906 = hang (hsep [ptext SLIT("Class type variable"),
907 quotes (ppr clas_tyvar),
908 ptext SLIT("does not appear in method signature")])
912 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
914 forAllWarn doc ty tyvar
915 = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
916 () | not warn_unused -> returnRn ()
918 -> getModeRn `thenRn` \ mode ->
921 InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
922 -- unless DEBUG is on, in which case it is slightly
923 -- informative. They can arise from mkRhsTyLam,
924 #endif -- leading to (say) f :: forall a b. [b] -> [b]
927 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
928 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
930 (ptext SLIT("In") <+> doc)
934 badRuleLhsErr name lhs
935 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
936 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
938 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
941 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
942 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
943 ptext SLIT("does not appear on left hand side")]
945 badExtName :: ExtName -> Message
947 = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
949 dupClassAssertWarn ctxt (assertion : dups)
950 = sep [hsep [ptext SLIT("Duplicate class assertion"),
951 quotes (ppr assertion),
952 ptext SLIT("in the context:")],
953 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
955 naughtyCCallContextErr (HsPClass clas _)
956 = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
957 ptext SLIT("in a context")]