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
23 import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
24 import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName,
25 lookupOrigNames, lookupSysBinder,
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 )
37 import Name ( Name, OccName, nameOccName, NamedThing(..) )
39 import FiniteMap ( elemFM )
40 import PrelInfo ( derivableClassKeys, cCallishClassKeys )
41 import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
42 bindIO_RDR, returnIO_RDR
44 import Bag ( bagToList )
45 import List ( partition, nub )
47 import SrcLoc ( SrcLoc )
48 import CmdLineOpts ( opt_GlasgowExts, opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
49 import Unique ( Uniquable(..) )
50 import ErrUtils ( Message )
51 import CStrings ( isCLabelString )
55 @rnDecl@ `renames' declarations.
56 It simultaneously performs dependency analysis and precedence parsing.
57 It also does the following error checks:
60 Checks that tyvars are used properly. This includes checking
61 for undefined tyvars, and tyvars in contexts that are ambiguous.
62 (Some of this checking has now been moved to module @TcMonoType@,
63 since we don't have functional dependency information at this point.)
65 Checks that all variable occurences are defined.
67 Checks the @(..)@ etc constraints in the export list.
71 %*********************************************************
73 \subsection{Value declarations}
75 %*********************************************************
78 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
79 -- The decls get reversed, but that's ok
82 = go emptyFVs [] decls
84 -- Fixity and deprecations have been dealt with already; ignore them
85 go fvs ds' [] = returnRn (ds', fvs)
86 go fvs ds' (FixD _:ds) = go fvs ds' ds
87 go fvs ds' (DeprecD _:ds) = go fvs ds' ds
88 go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
89 go (fvs `plusFV` fvs') (d':ds') ds
93 %*********************************************************
95 \subsection{Value declarations}
97 %*********************************************************
100 -- rnDecl does all the work
101 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
103 rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
104 returnRn (ValD new_binds, fvs)
107 rnDecl (SigD (IfaceSig name ty id_infos loc))
109 lookupTopBndrRn name `thenRn` \ name' ->
110 rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
111 mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
112 returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
114 doc_str = text "the interface signature for" <+> quotes (ppr name)
117 %*********************************************************
119 \subsection{Type declarations}
121 %*********************************************************
123 @rnTyDecl@ uses the `global name function' to create a new type
124 declaration in which local names have been replaced by their original
125 names, reporting any unknown names.
127 Renaming type variables is a pain. Because they now contain uniques,
128 it is necessary to pass in an association list which maps a parsed
129 tyvar to its @Name@ representation.
130 In some cases (type signatures of values),
131 it is even necessary to go over the type first
132 in order to get the set of tyvars used by it, make an assoc list,
133 and then go over it again to rename the tyvars!
134 However, we can also do some scoping checks at the same time.
137 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc))
138 = pushSrcLocRn src_loc $
139 lookupTopBndrRn tycon `thenRn` \ tycon' ->
140 bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
141 rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
142 checkDupOrQualNames data_doc con_names `thenRn_`
143 mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
144 rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
145 ASSERT(isNoDataPragmas pragmas)
146 returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
147 derivings' noDataPragmas src_loc),
148 cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
150 data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
151 con_names = map conDeclName condecls
153 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
154 = pushSrcLocRn src_loc $
155 lookupTopBndrRn name `thenRn` \ name' ->
156 bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
157 rnHsType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) ->
158 returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
160 syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
162 -- For H98 we do *not* universally quantify on the RHS of a synonym
163 -- Silently discard context... but the tyvars in the rest won't be in scope
164 unquantify (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty
167 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
168 tname dname dwname snames src_loc))
169 = pushSrcLocRn src_loc $
171 lookupTopBndrRn cname `thenRn` \ cname' ->
173 -- Deal with the implicit tycon and datacon name
174 -- They aren't in scope (because they aren't visible to the user)
175 -- and what we want to do is simply look them up in the cache;
176 -- we jolly well ought to get a 'hit' there!
177 -- So the 'Imported' part of this call is not relevant.
178 -- Unclean; but since these two are the only place this happens
179 -- I can't work up the energy to do it more beautifully
180 lookupSysBinder tname `thenRn` \ tname' ->
181 lookupSysBinder dname `thenRn` \ dname' ->
182 lookupSysBinder dwname `thenRn` \ dwname' ->
183 mapRn lookupSysBinder snames `thenRn` \ snames' ->
185 -- Tyvars scope over bindings and context
186 bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
188 -- Check the superclasses
189 rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
191 -- Check the functional dependencies
192 rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
194 -- Check the signatures
196 -- First process the class op sigs, then the fixity sigs.
197 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
199 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
200 mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
202 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
204 renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
207 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
208 rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) ->
210 -- Typechecker is responsible for checking that we only
211 -- give default-method bindings for things in this class.
212 -- The renamer *could* check this for class decls, but can't
213 -- for instance decls.
215 ASSERT(isNoClassPragmas pragmas)
216 returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
217 NoClassPragmas tname' dname' dwname' snames' src_loc),
226 cls_doc = text "the declaration for class" <+> ppr cname
227 sig_doc = text "the signatures for class" <+> ppr cname
228 meth_doc = text "the default-methods for class" <+> ppr cname
230 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
231 meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
233 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
234 = pushSrcLocRn locn $
235 lookupTopBndrRn op `thenRn` \ op_name ->
237 -- Check the signature
238 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
240 check_in_op_ty clas_tyvar =
241 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
242 (classTyVarNotInOpTyErr clas_tyvar sig)
244 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
246 -- Make the default-method name
247 (case maybe_dm_stuff of
248 Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl
250 Just (dm_rdr_name, explicit_dm)
251 -> -- Imported class that has a default method decl
252 -- See comments with tname, snames, above
253 lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
254 returnRn (Just (dm_name, explicit_dm),
255 if explicit_dm then unitFV dm_name else emptyFVs)
256 -- An imported class decl for a class decl that had an explicit default
257 -- method, mentions, rather than defines,
258 -- the default method, so we must arrange to pull it in
259 ) `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
261 returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)
265 %*********************************************************
267 \subsection{Instance declarations}
269 %*********************************************************
272 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc))
273 = pushSrcLocRn src_loc $
274 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
276 inst_tyvars = case inst_ty' of
277 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
279 -- (Slightly strangely) the forall-d tyvars scope over
280 -- the method bindings too
283 -- Rename the bindings
284 -- NB meth_names can be qualified!
285 checkDupNames meth_doc meth_names `thenRn_`
286 extendTyVarEnvFVRn inst_tyvars (
288 ) `thenRn` \ (mbinds', meth_fvs) ->
290 binders = map fst (bagToList (collectMonoBinders mbinds'))
291 binder_set = mkNameSet binders
293 -- Rename the prags and signatures.
294 -- Note that the type variables are not in scope here,
295 -- so that instance Eq a => Eq (T a) where
296 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
299 -- But the (unqualified) method names are in scope
300 bindLocalNames binders (
301 renameSigs (okInstDclSig binder_set) uprags
302 ) `thenRn` \ (new_uprags, prag_fvs) ->
304 (case maybe_dfun_rdr_name of
305 Nothing -> returnRn (Nothing, emptyFVs)
307 Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
308 returnRn (Just dfun_name, unitFV dfun_name)
309 ) `thenRn` \ (maybe_dfun_name, dfun_fv) ->
311 -- The typechecker checks that all the bindings are for the right class.
312 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc),
313 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
315 meth_doc = text "the bindings in an instance declaration"
316 meth_names = bagToList (collectMonoBinders mbinds)
319 %*********************************************************
321 \subsection{Default declarations}
323 %*********************************************************
326 rnDecl (DefD (DefaultDecl tys src_loc))
327 = pushSrcLocRn src_loc $
328 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
329 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
331 doc_str = text "a `default' declaration"
334 %*********************************************************
336 \subsection{Foreign declarations}
338 %*********************************************************
341 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
342 = pushSrcLocRn src_loc $
343 lookupOccRn name `thenRn` \ name' ->
346 | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
347 bindIO_RDR, returnIO_RDR]
349 lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
350 returnRn (addOneFV fvs name')
351 extra_fvs other = returnRn emptyFVs
353 checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
355 extra_fvs imp_exp `thenRn` \ fvs1 ->
357 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
358 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
361 fo_decl_msg = ptext SLIT("a foreign declaration")
362 isDyn = isDynamicExtName ext_nm
364 ok_ext_nm Dynamic = True
365 ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
366 ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
369 %*********************************************************
373 %*********************************************************
376 rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc))
377 = pushSrcLocRn src_loc $
378 lookupOccRn fn `thenRn` \ fn' ->
379 rnCoreBndrs vars $ \ vars' ->
380 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
381 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
382 returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc),
383 (fvs1 `plusFV` fvs2) `addOneFV` fn')
385 rnDecl (RuleD (IfaceRuleOut fn rule))
386 -- This one is used for BuiltInRules
387 -- The rule itself is already done, but the thing
388 -- to attach it to is not.
389 = lookupOccRn fn `thenRn` \ fn' ->
390 returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
392 rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
394 pushSrcLocRn src_loc $
396 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
397 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
398 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
400 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
401 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
402 checkRn (validRuleLhs ids lhs')
403 (badRuleLhsErr rule_name lhs') `thenRn_`
405 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
407 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
408 returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc),
409 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
411 doc = text "the transformation rule" <+> ptext rule_name
412 sig_tvs = extractRuleBndrsTyVars vars
414 get_var (RuleBndr v) = v
415 get_var (RuleBndrSig v _) = v
417 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
418 rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
419 returnRn (RuleBndrSig id t', fvs)
423 %*********************************************************
425 \subsection{Support code for type/data declarations}
427 %*********************************************************
430 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
432 rnDerivs Nothing -- derivs not specified
433 = returnRn (Nothing, emptyFVs)
436 = mapRn do_one clss `thenRn` \ clss' ->
437 returnRn (Just clss', mkNameSet clss')
439 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
440 checkRn (getUnique clas_name `elem` derivableClassKeys)
441 (derivingNonStdClassErr clas_name) `thenRn_`
446 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
447 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
449 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
450 rnConDecl (ConDecl name wkr tvs cxt details locn)
451 = pushSrcLocRn locn $
452 checkConName name `thenRn_`
453 lookupTopBndrRn name `thenRn` \ new_name ->
455 lookupSysBinder wkr `thenRn` \ new_wkr ->
456 -- See comments with ClassDecl
458 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
459 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
460 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
461 returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
462 cxt_fvs `plusFV` det_fvs)
464 doc = text "the definition of data constructor" <+> quotes (ppr name)
466 rnConDetails doc locn (VanillaCon tys)
467 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
468 returnRn (VanillaCon new_tys, fvs)
470 rnConDetails doc locn (InfixCon ty1 ty2)
471 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
472 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
473 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
475 rnConDetails doc locn (RecCon fields)
476 = checkDupOrQualNames doc field_names `thenRn_`
477 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
478 returnRn (RecCon new_fields, fvs)
480 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
482 rnField doc (names, ty)
483 = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
484 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
485 returnRn ((new_names, new_ty), fvs)
487 rnBangTy doc (Banged ty)
488 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
489 returnRn (Banged new_ty, fvs)
491 rnBangTy doc (Unbanged ty)
492 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
493 returnRn (Unbanged new_ty, fvs)
495 rnBangTy doc (Unpacked ty)
496 = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
497 returnRn (Unpacked new_ty, fvs)
499 -- This data decl will parse OK
501 -- treating "a" as the constructor.
502 -- It is really hard to make the parser spot this malformation.
503 -- So the renamer has to check that the constructor is legal
505 -- We can get an operator as the constructor, even in the prefix form:
506 -- data T = :% Int Int
507 -- from interface files, which always print in prefix form
510 = checkRn (isRdrDataCon name)
515 %*********************************************************
517 \subsection{Support code to rename types}
519 %*********************************************************
522 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
523 -- rnHsSigType is used for source-language type signatures,
524 -- which use *implicit* universal quantification.
525 rnHsSigType doc_str ty
526 = rnHsType (text "the type signature for" <+> doc_str) ty
528 ---------------------------------------
529 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
531 rnHsType doc (HsForAllTy Nothing ctxt ty)
532 -- Implicit quantifiction in source code (no kinds on tyvars)
533 -- Given the signature C => T we universally quantify
534 -- over FV(T) \ {in-scope-tyvars}
535 = getLocalNameEnv `thenRn` \ name_env ->
537 mentioned_in_tau = extractHsTyRdrTyVars ty
538 mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
539 mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
540 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned
542 rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
544 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
545 -- Explicit quantification.
546 -- Check that the forall'd tyvars are actually
547 -- mentioned in the type, and produce a warning if not
549 mentioned_in_tau = extractHsTyRdrTyVars tau
550 mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
551 mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
552 forall_tyvar_names = hsTyVarNames forall_tyvars
554 -- Explicitly quantified but not mentioned in ctxt or tau
555 warn_guys = filter (`notElem` mentioned) forall_tyvar_names
557 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
558 rnForAll doc forall_tyvars ctxt tau
560 rnHsType doc (HsTyVar tyvar)
561 = lookupOccRn tyvar `thenRn` \ tyvar' ->
562 returnRn (HsTyVar tyvar', unitFV tyvar')
564 rnHsType doc (HsFunTy ty1 ty2)
565 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
566 -- Might find a for-all as the arg of a function type
567 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
568 -- Or as the result. This happens when reading Prelude.hi
569 -- when we find return :: forall m. Monad m -> forall a. a -> m a
570 returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
572 rnHsType doc (HsListTy ty)
573 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
574 returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
576 -- Unboxed tuples are allowed to have poly-typed arguments. These
577 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
578 rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
579 -- Don't do lookupOccRn, because this is built-in syntax
580 -- so it doesn't need to be in scope
581 = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) ->
582 returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
584 n' = tupleTyCon_name boxity (length tys)
587 rnHsType doc (HsAppTy ty1 ty2)
588 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
589 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
590 returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
592 rnHsType doc (HsPredTy pred)
593 = rnPred doc pred `thenRn` \ (pred', fvs) ->
594 returnRn (HsPredTy pred', fvs)
596 rnHsType doc (HsUsgForAllTy uv_rdr ty)
597 = bindUVarRn doc uv_rdr $ \ uv_name ->
598 rnHsType doc ty `thenRn` \ (ty', fvs) ->
599 returnRn (HsUsgForAllTy uv_name ty',
602 rnHsType doc (HsUsgTy usg ty)
603 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
604 rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
605 -- A for-all can occur inside a usage annotation
606 returnRn (HsUsgTy usg' ty',
607 usg_fvs `plusFV` ty_fvs)
609 newUsg usg = case usg of
610 HsUsOnce -> returnRn (HsUsOnce, emptyFVs)
611 HsUsMany -> returnRn (HsUsMany, emptyFVs)
612 HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
613 returnRn (HsUsVar uv_name, emptyFVs)
615 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
619 -- We use lookupOcc here because this is interface file only stuff
620 -- and we need the workers...
621 rnHsTupCon (HsTupCon n boxity)
622 = lookupOccRn n `thenRn` \ n' ->
623 returnRn (HsTupCon n' boxity, unitFV n')
625 rnHsTupConWkr (HsTupCon n boxity)
626 -- Tuple construtors are for the *worker* of the tuple
627 -- Going direct saves needless messing about
628 = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
629 returnRn (HsTupCon n' boxity, unitFV n')
633 rnForAll doc forall_tyvars ctxt ty
634 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
635 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
636 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
637 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
638 cxt_fvs `plusFV` ty_fvs)
642 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
644 = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) ->
646 (_, dups) = removeDupsEq theta
647 -- We only have equality, not ordering
649 -- Check for duplicate assertions
650 -- If this isn't an error, then it ought to be:
651 mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_`
652 returnRn (theta, plusFVs fvs_s)
654 --Someone discovered that @CCallable@ and @CReturnable@
655 -- could be used in contexts such as:
656 -- foo :: CCallable a => a -> PrimIO Int
657 -- Doing this utterly wrecks the whole point of introducing these
658 -- classes so we specifically check that this isn't being done.
659 rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)->
660 checkRn (not (bad_pred pred'))
661 (naughtyCCallContextErr pred') `thenRn_`
662 returnRn (pred', fvs)
664 bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
665 bad_pred other = False
668 rnPred doc (HsPClass clas tys)
669 = lookupOccRn clas `thenRn` \ clas_name ->
670 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
671 returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
673 rnPred doc (HsPIParam n ty)
674 = newIPName n `thenRn` \ name ->
675 rnHsType doc ty `thenRn` \ (ty', fvs) ->
676 returnRn (HsPIParam name ty', fvs)
680 rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
683 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
684 returnRn (theta, plusFVs fvs_s)
687 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
688 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
689 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
691 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
693 = lookupOccRn tyvar `thenRn` \ tyvar' ->
694 returnRn (tyvar', unitFV tyvar')
697 %*********************************************************
701 %*********************************************************
704 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
706 rnIdInfo (HsWorker worker)
707 = lookupOccRn worker `thenRn` \ worker' ->
708 returnRn (HsWorker worker', unitFV worker')
710 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
711 returnRn (HsUnfold inline expr', fvs)
712 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
713 rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
714 rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
718 @UfCore@ expressions.
721 rnCoreExpr (UfType ty)
722 = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
723 returnRn (UfType ty', fvs)
726 = lookupOccRn v `thenRn` \ v' ->
727 returnRn (UfVar v', unitFV v')
730 = returnRn (UfLit l, emptyFVs)
732 rnCoreExpr (UfLitLit l ty)
733 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
734 returnRn (UfLitLit l ty', fvs)
736 rnCoreExpr (UfCCall cc ty)
737 = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) ->
738 returnRn (UfCCall cc ty', fvs)
740 rnCoreExpr (UfTuple con args)
741 = rnHsTupConWkr con `thenRn` \ (con', fvs1) ->
742 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
743 returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
745 rnCoreExpr (UfApp fun arg)
746 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
747 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
748 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
750 rnCoreExpr (UfCase scrut bndr alts)
751 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
752 bindCoreLocalFVRn bndr ( \ bndr' ->
753 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
754 returnRn (UfCase scrut' bndr' alts', fvs2)
755 ) `thenRn` \ (case', fvs3) ->
756 returnRn (case', fvs1 `plusFV` fvs3)
758 rnCoreExpr (UfNote note expr)
759 = rnNote note `thenRn` \ (note', fvs1) ->
760 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
761 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
763 rnCoreExpr (UfLam bndr body)
764 = rnCoreBndr bndr $ \ bndr' ->
765 rnCoreExpr body `thenRn` \ (body', fvs) ->
766 returnRn (UfLam bndr' body', fvs)
768 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
769 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
770 rnCoreBndr bndr ( \ bndr' ->
771 rnCoreExpr body `thenRn` \ (body', fvs2) ->
772 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
773 ) `thenRn` \ (result, fvs3) ->
774 returnRn (result, fvs1 `plusFV` fvs3)
776 rnCoreExpr (UfLet (UfRec pairs) body)
777 = rnCoreBndrs bndrs $ \ bndrs' ->
778 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
779 rnCoreExpr body `thenRn` \ (body', fvs2) ->
780 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
782 (bndrs, rhss) = unzip pairs
786 rnCoreBndr (UfValBinder name ty) thing_inside
787 = rnHsType doc ty `thenRn` \ (ty', fvs1) ->
788 bindCoreLocalFVRn name ( \ name' ->
789 thing_inside (UfValBinder name' ty')
790 ) `thenRn` \ (result, fvs2) ->
791 returnRn (result, fvs1 `plusFV` fvs2)
793 doc = text "unfolding id"
795 rnCoreBndr (UfTyBinder name kind) thing_inside
796 = bindCoreLocalFVRn name $ \ name' ->
797 thing_inside (UfTyBinder name' kind)
799 rnCoreBndrs [] thing_inside = thing_inside []
800 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
801 rnCoreBndrs bs $ \ names' ->
802 thing_inside (name':names')
806 rnCoreAlt (con, bndrs, rhs)
807 = rnUfCon con bndrs `thenRn` \ (con', fvs1) ->
808 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
809 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
810 returnRn ((con', bndrs', rhs'), fvs2)
811 ) `thenRn` \ (result, fvs3) ->
812 returnRn (result, fvs1 `plusFV` fvs3)
815 = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
816 returnRn (UfCoerce ty', fvs)
818 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
819 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
820 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
824 = returnRn (UfDefault, emptyFVs)
826 rnUfCon (UfTupleAlt tup_con) bndrs
827 = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) ->
828 returnRn (UfDataAlt con', fvs)
829 -- Makes the type checker a little easier
831 rnUfCon (UfDataAlt con) _
832 = lookupOccRn con `thenRn` \ con' ->
833 returnRn (UfDataAlt con', unitFV con')
835 rnUfCon (UfLitAlt lit) _
836 = returnRn (UfLitAlt lit, emptyFVs)
838 rnUfCon (UfLitLitAlt lit ty) _
839 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
840 returnRn (UfLitLitAlt lit ty', fvs)
843 %*********************************************************
845 \subsection{Rule shapes}
847 %*********************************************************
849 Check the shape of a transformation rule LHS. Currently
850 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
851 not one of the @forall@'d variables.
854 validRuleLhs foralls lhs
857 check (HsApp e1 e2) = check e1
858 check (HsVar v) | v `notElem` foralls = True
863 %*********************************************************
867 %*********************************************************
870 derivingNonStdClassErr clas
871 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
873 classTyVarNotInOpTyErr clas_tyvar sig
874 = hang (hsep [ptext SLIT("Class type variable"),
875 quotes (ppr clas_tyvar),
876 ptext SLIT("does not appear in method signature")])
880 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
882 forAllWarn doc ty tyvar
883 | not opt_WarnUnusedMatches = returnRn ()
885 = getModeRn `thenRn` \ mode ->
888 InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
889 -- unless DEBUG is on, in which case it is slightly
890 -- informative. They can arise from mkRhsTyLam,
891 #endif -- leading to (say) f :: forall a b. [b] -> [b]
895 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
896 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
898 (ptext SLIT("In") <+> doc))
901 badRuleLhsErr name lhs
902 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
903 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
905 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
908 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
909 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
910 ptext SLIT("does not appear on left hand side")]
912 badExtName :: ExtName -> Message
914 = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
916 dupClassAssertWarn ctxt (assertion : dups)
917 = sep [hsep [ptext SLIT("Duplicate class assertion"),
918 quotes (ppr assertion),
919 ptext SLIT("in the context:")],
920 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
922 naughtyCCallContextErr (HsPClass clas _)
923 = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
924 ptext SLIT("in a context")]