2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
7 module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
9 #include "HsVersions.h"
14 import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes )
15 import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
16 import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
17 extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
22 import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
23 import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
25 bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
26 bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
27 bindCoreLocalFVRn, bindCoreLocalsFVRn,
28 checkDupOrQualNames, checkDupNames,
29 mkImportedGlobalName, mkImportedGlobalFromRdrName,
30 newDFunName, getDFunKey, newImplicitBinder,
31 FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
35 import FunDeps ( oclose )
37 import Name ( Name, OccName,
38 ExportFlag(..), Provenance(..),
39 nameOccName, NamedThing(..)
42 import OccName ( mkDefaultMethodOcc )
43 import BasicTypes ( TopLevelFlag(..) )
44 import FiniteMap ( elemFM )
45 import PrelInfo ( derivableClassKeys,
46 deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
48 import Bag ( bagToList )
49 import List ( partition, nub )
51 import SrcLoc ( SrcLoc )
52 import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
53 import Unique ( Uniquable(..) )
54 import UniqFM ( lookupUFM )
55 import Maybes ( maybeToBool, catMaybes )
59 @rnDecl@ `renames' declarations.
60 It simultaneously performs dependency analysis and precedence parsing.
61 It also does the following error checks:
64 Checks that tyvars are used properly. This includes checking
65 for undefined tyvars, and tyvars in contexts that are ambiguous.
66 (Some of this checking has now been moved to module @TcMonoType@,
67 since we don't have functional dependency information at this point.)
69 Checks that all variable occurences are defined.
71 Checks the @(..)@ etc constraints in the export list.
75 %*********************************************************
77 \subsection{Value declarations}
79 %*********************************************************
82 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
83 -- The decls get reversed, but that's ok
86 = go emptyFVs [] decls
88 -- Fixity decls have been dealt with already; ignore them
89 go fvs ds' [] = returnRn (ds', fvs)
90 go fvs ds' (FixD _:ds) = go fvs ds' ds
91 go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
92 go (fvs `plusFV` fvs') (d':ds') ds
96 %*********************************************************
98 \subsection{Value declarations}
100 %*********************************************************
103 -- rnDecl does all the work
104 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
106 rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
107 returnRn (ValD new_binds, fvs)
110 rnDecl (SigD (IfaceSig name ty id_infos loc))
112 lookupBndrRn name `thenRn` \ name' ->
113 rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) ->
114 mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
115 returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
117 doc_str = text "the interface signature for" <+> quotes (ppr name)
120 %*********************************************************
122 \subsection{Type declarations}
124 %*********************************************************
126 @rnTyDecl@ uses the `global name function' to create a new type
127 declaration in which local names have been replaced by their original
128 names, reporting any unknown names.
130 Renaming type variables is a pain. Because they now contain uniques,
131 it is necessary to pass in an association list which maps a parsed
132 tyvar to its @Name@ representation.
133 In some cases (type signatures of values),
134 it is even necessary to go over the type first
135 in order to get the set of tyvars used by it, make an assoc list,
136 and then go over it again to rename the tyvars!
137 However, we can also do some scoping checks at the same time.
140 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
141 = pushSrcLocRn src_loc $
142 lookupBndrRn tycon `thenRn` \ tycon' ->
143 bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
144 rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
145 checkDupOrQualNames data_doc con_names `thenRn_`
146 mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
147 rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
148 ASSERT(isNoDataPragmas pragmas)
149 returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls'
150 derivings' noDataPragmas src_loc),
151 cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
153 data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
154 con_names = map conDeclName condecls
156 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
157 = pushSrcLocRn src_loc $
158 lookupBndrRn name `thenRn` \ name' ->
159 bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
160 rnHsType syn_doc ty `thenRn` \ (ty', ty_fvs) ->
161 returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
163 syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
165 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
166 tname dname snames src_loc))
167 = pushSrcLocRn src_loc $
169 lookupBndrRn cname `thenRn` \ cname' ->
171 -- Deal with the implicit tycon and datacon name
172 -- They aren't in scope (because they aren't visible to the user)
173 -- and what we want to do is simply look them up in the cache;
174 -- we jolly well ought to get a 'hit' there!
175 -- So the 'Imported' part of this call is not relevant.
176 -- Unclean; but since these two are the only place this happens
177 -- I can't work up the energy to do it more beautifully
178 mkImportedGlobalFromRdrName tname `thenRn` \ tname' ->
179 mkImportedGlobalFromRdrName dname `thenRn` \ dname' ->
180 mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' ->
182 -- Tyvars scope over bindings and context
183 bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
185 -- Check the superclasses
186 rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
188 -- Check the functional dependencies
189 rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
191 -- Check the signatures
193 -- First process the class op sigs, then the fixity sigs.
194 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
195 (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
197 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
198 mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs
199 `thenRn` \ (sigs', sig_fvs) ->
200 mapRn_ (unknownSigErr) non_sigs `thenRn_`
202 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
204 renameSigs False binders lookupOccRn fix_sigs
205 `thenRn` \ (fixs', fix_fvs) ->
208 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
210 `thenRn` \ (mbinds', meth_fvs) ->
212 -- Typechecker is responsible for checking that we only
213 -- give default-method bindings for things in this class.
214 -- The renamer *could* check this for class decls, but can't
215 -- for instance decls.
217 ASSERT(isNoClassPragmas pragmas)
218 returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
219 NoClassPragmas tname' dname' snames' src_loc),
228 cls_doc = text "the declaration for class" <+> ppr cname
229 sig_doc = text "the signatures for class" <+> ppr cname
230 meth_doc = text "the default-methods for class" <+> ppr cname
232 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
233 meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
234 meth_rdr_names = map fst meth_rdr_names_w_locs
236 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
237 = pushSrcLocRn locn $
238 lookupBndrRn op `thenRn` \ op_name ->
240 -- Check the signature
241 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
243 check_in_op_ty clas_tyvar =
244 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
245 (classTyVarNotInOpTyErr clas_tyvar sig)
247 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
249 -- Make the default-method name
250 getModeRn `thenRn` \ mode ->
252 SourceMode -> -- Source class decl
253 newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name ->
254 returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
257 -> -- Imported class that has a default method decl
258 -- See comments with tname, snames, above
259 lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name ->
260 returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
261 -- An imported class decl for a class decl that had an explicit default
262 -- method, mentions, rather than defines,
263 -- the default method, so we must arrange to pull it in
264 ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
266 returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
270 %*********************************************************
272 \subsection{Instance declarations}
274 %*********************************************************
277 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
278 = pushSrcLocRn src_loc $
279 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
281 inst_tyvars = case inst_ty' of
282 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
284 -- (Slightly strangely) the forall-d tyvars scope over
285 -- the method bindings too
288 -- Rename the bindings
289 -- NB meth_names can be qualified!
290 checkDupNames meth_doc meth_names `thenRn_`
291 extendTyVarEnvFVRn inst_tyvars (
293 ) `thenRn` \ (mbinds', meth_fvs) ->
295 binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
297 -- Delete sigs (&report) sigs that aren't allowed inside an
303 (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
305 okInInstDecl (FixSig _) = False
306 okInInstDecl (Sig _ _ _) = False
307 okInInstDecl _ = True
310 -- You can't have fixity decls & type signatures
311 -- within an instance declaration.
312 mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
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]) #-}
319 renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
321 getModeRn `thenRn` \ mode ->
323 InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name ->
324 returnRn (dfun_name, unitFV dfun_name)
325 SourceMode -> newDFunName (getDFunKey inst_ty') src_loc
326 `thenRn` \ dfun_name ->
327 returnRn (dfun_name, emptyFVs)
329 `thenRn` \ (dfun_name, dfun_fv) ->
331 -- The typechecker checks that all the bindings are for the right class.
332 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
333 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
335 meth_doc = text "the bindings in an instance declaration"
336 meth_names = bagToList (collectMonoBinders mbinds)
339 %*********************************************************
341 \subsection{Default declarations}
343 %*********************************************************
346 rnDecl (DefD (DefaultDecl tys src_loc))
347 = pushSrcLocRn src_loc $
348 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
349 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
351 doc_str = text "a `default' declaration"
354 %*********************************************************
356 \subsection{Foreign declarations}
358 %*********************************************************
361 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
362 = pushSrcLocRn src_loc $
363 lookupOccRn name `thenRn` \ name' ->
365 fvs1 = case imp_exp of
366 FoImport _ | not isDyn -> emptyFVs
368 FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
371 | otherwise -> mkNameSet [name']
374 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
375 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
378 fo_decl_msg = ptext SLIT("a foreign declaration")
379 isDyn = isDynamic ext_nm
382 %*********************************************************
386 %*********************************************************
389 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
390 = pushSrcLocRn src_loc $
391 lookupOccRn var `thenRn` \ var' ->
392 rnRuleBody body `thenRn` \ (body', fvs) ->
393 returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
395 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
397 pushSrcLocRn src_loc $
399 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
400 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
401 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
403 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
404 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
405 checkRn (validRuleLhs ids lhs')
406 (badRuleLhsErr rule_name lhs') `thenRn_`
408 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
410 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
411 returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
412 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
414 doc = text "the transformation rule" <+> ptext rule_name
415 sig_tvs = extractRuleBndrsTyVars vars
417 get_var (RuleBndr v) = v
418 get_var (RuleBndrSig v _) = v
420 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
421 rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
422 returnRn (RuleBndrSig id t', fvs)
426 %*********************************************************
428 \subsection{Support code for type/data declarations}
430 %*********************************************************
433 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
435 rnDerivs Nothing -- derivs not specified
436 = returnRn (Nothing, emptyFVs)
439 = mapRn do_one clss `thenRn` \ clss' ->
440 returnRn (Just clss', mkNameSet clss')
442 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
443 checkRn (getUnique clas_name `elem` derivableClassKeys)
444 (derivingNonStdClassErr clas_name) `thenRn_`
449 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
450 conDeclName (ConDecl n _ _ _ l) = (n,l)
452 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
453 rnConDecl (ConDecl name tvs cxt details locn)
454 = pushSrcLocRn locn $
455 checkConName name `thenRn_`
456 lookupBndrRn name `thenRn` \ new_name ->
457 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
458 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
459 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
460 returnRn (ConDecl new_name new_tyvars new_context new_details locn,
461 cxt_fvs `plusFV` det_fvs)
463 doc = text "the definition of data constructor" <+> quotes (ppr name)
465 rnConDetails doc locn (VanillaCon tys)
466 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
467 returnRn (VanillaCon new_tys, fvs)
469 rnConDetails doc locn (InfixCon ty1 ty2)
470 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
471 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
472 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
474 rnConDetails doc locn (NewCon ty mb_field)
475 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
476 rn_field mb_field `thenRn` \ new_mb_field ->
477 returnRn (NewCon new_ty new_mb_field, fvs)
479 rn_field Nothing = returnRn Nothing
481 lookupBndrRn f `thenRn` \ new_f ->
482 returnRn (Just new_f)
484 rnConDetails doc locn (RecCon fields)
485 = checkDupOrQualNames doc field_names `thenRn_`
486 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
487 returnRn (RecCon new_fields, fvs)
489 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
491 rnField doc (names, ty)
492 = mapRn lookupBndrRn names `thenRn` \ new_names ->
493 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
494 returnRn ((new_names, new_ty), fvs)
496 rnBangTy doc (Banged ty)
497 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
498 returnRn (Banged new_ty, fvs)
500 rnBangTy doc (Unbanged ty)
501 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
502 returnRn (Unbanged new_ty, fvs)
504 rnBangTy doc (Unpacked ty)
505 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
506 returnRn (Unpacked new_ty, fvs)
508 -- This data decl will parse OK
510 -- treating "a" as the constructor.
511 -- It is really hard to make the parser spot this malformation.
512 -- So the renamer has to check that the constructor is legal
514 -- We can get an operator as the constructor, even in the prefix form:
515 -- data T = :% Int Int
516 -- from interface files, which always print in prefix form
519 = checkRn (isRdrDataCon name)
524 %*********************************************************
526 \subsection{Support code to rename types}
528 %*********************************************************
531 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
532 -- rnHsSigType is used for source-language type signatures,
533 -- which use *implicit* universal quantification.
534 rnHsSigType doc_str ty
535 = rnHsPolyType (text "the type signature for" <+> doc_str) ty
537 ---------------------------------------
538 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
539 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
540 -- The former is called for the top level of type sigs and function args.
542 ---------------------------------------
543 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
544 -- From 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 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
552 checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
553 rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
555 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
556 -- Explicit quantification.
557 -- Check that the forall'd tyvars are a subset of the
558 -- free tyvars in the tau-type part
559 -- That's only a warning... unless the tyvar is constrained by a
560 -- context in which case it's an error
562 mentioned_in_tau = extractHsTyRdrTyVars tau
563 mentioned_in_ctxt = nub [tv | p <- ctxt,
565 tv <- extractHsTyRdrTyVars ty]
566 tys_of_pred (HsPClass clas tys) = tys
567 tys_of_pred (HsPIParam n ty) = [ty]
569 dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
570 -- dubious = explicitly quantified but not mentioned in tau type
572 (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
573 -- bad = explicitly quantified and constrained, but not mentioned in tau
574 -- warn = explicitly quantified but not mentioned in ctxt or tau
576 forall_tyvar_names = map getTyVarName forall_tyvars
578 -- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
579 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
580 checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
581 rnForAll doc forall_tyvars ctxt' tau
583 rnHsPolyType doc other_ty = rnHsType doc other_ty
586 -- Check that each constraint mentions at least one of the forall'd type variables
587 -- Since the forall'd type variables are a subset of the free tyvars
588 -- of the tau-type part, this guarantees that every constraint mentions
589 -- at least one of the free tyvars in ty
590 checkConstraints doc forall_tyvars tau_vars ctxt ty
591 = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
592 returnRn (catMaybes maybe_ctxt')
593 -- Remove problem ones, to avoid duplicate error message.
595 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
596 | not_univ = failWithRn Nothing (univErr doc p ty)
597 | otherwise = returnRn (Just p)
599 ct_vars = extractHsTysRdrTyVars tys
600 not_univ = -- At least one of the tyvars in each constraint must
601 -- be universally quantified. This restriction isn't in Hugs
602 not (any (`elem` forall_tyvars) ct_vars)
603 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
606 rnForAll doc forall_tyvars ctxt ty
607 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
608 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
609 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
610 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
611 cxt_fvs `plusFV` ty_fvs)
613 ---------------------------------------
614 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
615 = addWarnRn (unexpectedForAllTy ty) `thenRn_`
618 rnHsType doc (MonoTyVar tyvar)
619 = lookupOccRn tyvar `thenRn` \ tyvar' ->
620 returnRn (MonoTyVar tyvar', unitFV tyvar')
622 rnHsType doc (MonoFunTy ty1 ty2)
623 = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
624 -- Might find a for-all as the arg of a function type
625 rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
626 -- Or as the result. This happens when reading Prelude.hi
627 -- when we find return :: forall m. Monad m -> forall a. a -> m a
628 returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
630 rnHsType doc (MonoListTy ty)
631 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
632 returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
634 -- Unboxed tuples are allowed to have poly-typed arguments. These
635 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
636 rnHsType doc (MonoTupleTy tys boxed)
638 then mapFvRn (rnHsType doc) tys
639 else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) ->
640 returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
642 tup_con_name = tupleTyCon_name boxed (length tys)
644 rnHsType doc (MonoTyApp ty1 ty2)
645 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
646 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
647 returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
649 rnHsType doc (MonoDictTy clas tys)
650 = lookupOccRn clas `thenRn` \ clas' ->
651 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
652 returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
654 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
655 = bindUVarRn doc uv_rdr $ \ uv_name ->
656 rnHsType doc ty `thenRn` \ (ty', fvs) ->
657 returnRn (MonoUsgForAllTy uv_name ty',
660 rnHsType doc (MonoUsgTy usg ty)
661 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
662 rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) ->
663 -- A for-all can occur inside a usage annotation
664 returnRn (MonoUsgTy usg' ty',
665 usg_fvs `plusFV` ty_fvs)
667 newUsg usg = case usg of
668 MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
669 MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
670 MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
671 returnRn (MonoUsVar uv_name, emptyFVs)
673 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
678 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
681 = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
683 (_, dup_asserts) = removeDups (cmpHsPred compare) theta
685 -- Check for duplicate assertions
686 -- If this isn't an error, then it ought to be:
687 mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
689 returnRn (theta, plusFVs fvs_s)
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)
695 rnPred doc (HsPIParam n ty)
696 = getIPName n `thenRn` \ name ->
697 rnHsType doc ty `thenRn` \ (ty', fvs) ->
698 returnRn (HsPIParam name ty', fvs)
702 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
705 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
706 returnRn (theta, plusFVs fvs_s)
709 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
710 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
711 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
713 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
715 = lookupOccRn tyvar `thenRn` \ tyvar' ->
716 returnRn (tyvar', unitFV tyvar')
719 %*********************************************************
723 %*********************************************************
726 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
728 rnIdInfo (HsWorker worker)
729 = lookupOccRn worker `thenRn` \ worker' ->
730 returnRn (HsWorker worker', unitFV worker')
732 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
733 returnRn (HsUnfold inline expr', fvs)
734 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
735 rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
736 rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs, emptyFVs)
737 rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info, emptyFVs)
738 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
739 `thenRn` \ (rule_body', fvs) ->
740 returnRn (HsSpecialise rule_body', fvs)
742 rnRuleBody (UfRuleBody str vars args rhs)
743 = rnCoreBndrs vars $ \ vars' ->
744 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
745 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
746 returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
749 @UfCore@ expressions.
752 rnCoreExpr (UfType ty)
753 = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
754 returnRn (UfType ty', fvs)
757 = lookupOccRn v `thenRn` \ v' ->
758 returnRn (UfVar v', unitFV v')
760 rnCoreExpr (UfCon con args)
761 = rnUfCon con `thenRn` \ (con', fvs1) ->
762 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
763 returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
765 rnCoreExpr (UfTuple con args)
766 = lookupOccRn con `thenRn` \ con' ->
767 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) ->
768 returnRn (UfTuple con' args', fvs `addOneFV` con')
770 rnCoreExpr (UfApp fun arg)
771 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
772 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
773 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
775 rnCoreExpr (UfCase scrut bndr alts)
776 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
777 bindCoreLocalFVRn bndr ( \ bndr' ->
778 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
779 returnRn (UfCase scrut' bndr' alts', fvs2)
780 ) `thenRn` \ (case', fvs3) ->
781 returnRn (case', fvs1 `plusFV` fvs3)
783 rnCoreExpr (UfNote note expr)
784 = rnNote note `thenRn` \ (note', fvs1) ->
785 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
786 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
788 rnCoreExpr (UfLam bndr body)
789 = rnCoreBndr bndr $ \ bndr' ->
790 rnCoreExpr body `thenRn` \ (body', fvs) ->
791 returnRn (UfLam bndr' body', fvs)
793 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
794 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
795 rnCoreBndr bndr ( \ bndr' ->
796 rnCoreExpr body `thenRn` \ (body', fvs2) ->
797 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
798 ) `thenRn` \ (result, fvs3) ->
799 returnRn (result, fvs1 `plusFV` fvs3)
801 rnCoreExpr (UfLet (UfRec pairs) body)
802 = rnCoreBndrs bndrs $ \ bndrs' ->
803 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
804 rnCoreExpr body `thenRn` \ (body', fvs2) ->
805 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
807 (bndrs, rhss) = unzip pairs
811 rnCoreBndr (UfValBinder name ty) thing_inside
812 = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
813 bindCoreLocalFVRn name ( \ name' ->
814 thing_inside (UfValBinder name' ty')
815 ) `thenRn` \ (result, fvs2) ->
816 returnRn (result, fvs1 `plusFV` fvs2)
818 doc = text "unfolding id"
820 rnCoreBndr (UfTyBinder name kind) thing_inside
821 = bindCoreLocalFVRn name $ \ name' ->
822 thing_inside (UfTyBinder name' kind)
824 rnCoreBndrs [] thing_inside = thing_inside []
825 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
826 rnCoreBndrs bs $ \ names' ->
827 thing_inside (name':names')
831 rnCoreAlt (con, bndrs, rhs)
832 = rnUfCon con `thenRn` \ (con', fvs1) ->
833 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
834 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
835 returnRn ((con', bndrs', rhs'), fvs2)
836 ) `thenRn` \ (result, fvs3) ->
837 returnRn (result, fvs1 `plusFV` fvs3)
840 = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
841 returnRn (UfCoerce ty', fvs)
843 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
844 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
845 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
849 = returnRn (UfDefault, emptyFVs)
851 rnUfCon (UfDataCon con)
852 = lookupOccRn con `thenRn` \ con' ->
853 returnRn (UfDataCon con', unitFV con')
855 rnUfCon (UfLitCon lit)
856 = returnRn (UfLitCon lit, emptyFVs)
858 rnUfCon (UfLitLitCon lit ty)
859 = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
860 returnRn (UfLitLitCon lit ty', fvs)
862 rnUfCon (UfPrimOp op)
863 = lookupOccRn op `thenRn` \ op' ->
864 returnRn (UfPrimOp op', emptyFVs)
866 rnUfCon (UfCCallOp str is_dyn casm gc)
867 = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
870 %*********************************************************
872 \subsection{Rule shapes}
874 %*********************************************************
876 Check the shape of a transformation rule LHS. Currently
877 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
878 not one of the @forall@'d variables.
881 validRuleLhs foralls lhs
884 check (HsApp e1 e2) = check e1
885 check (HsVar v) | v `notElem` foralls = True
890 %*********************************************************
894 %*********************************************************
897 derivingNonStdClassErr clas
898 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
900 classTyVarNotInOpTyErr clas_tyvar sig
901 = hang (hsep [ptext SLIT("Class type variable"),
902 quotes (ppr clas_tyvar),
903 ptext SLIT("does not appear in method signature")])
906 dupClassAssertWarn ctxt (assertion : dups)
907 = sep [hsep [ptext SLIT("Duplicate class assertion"),
908 quotes (pprHsPred assertion),
909 ptext SLIT("in the context:")],
910 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
913 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
915 forAllWarn doc ty tyvar
916 | not opt_WarnUnusedMatches = 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]
928 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
929 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
931 (ptext SLIT("In") <+> doc))
934 forAllErr doc ty tyvar
936 sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
937 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
939 (ptext SLIT("In") <+> doc))
941 univErr doc constraint ty
942 = sep [ptext SLIT("All of the type variable(s) in the constraint")
943 <+> quotes (pprHsPred constraint)
944 <+> ptext SLIT("are already in scope"),
945 nest 4 (ptext SLIT("At least one must be universally quantified here"))
948 (ptext SLIT("In") <+> doc)
950 ambigErr doc constraint ty
951 = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
952 nest 4 (ptext SLIT("in the type:") <+> ppr ty),
953 nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
955 (ptext SLIT("In") <+> doc)
957 unexpectedForAllTy ty
958 = ptext SLIT("Unexpected forall type:") <+> ppr ty
960 badRuleLhsErr name lhs
961 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
962 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
964 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
967 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
968 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
969 ptext SLIT("does not appear on left hand side")]