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, pprClassAssertion, 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,
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 Name ( Name, OccName,
36 ExportFlag(..), Provenance(..),
37 nameOccName, NamedThing(..)
40 import OccName ( mkDefaultMethodOcc )
41 import BasicTypes ( TopLevelFlag(..) )
42 import FiniteMap ( elemFM )
43 import PrelInfo ( derivableClassKeys,
44 deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
46 import Bag ( bagToList )
47 import List ( partition, nub )
49 import SrcLoc ( SrcLoc )
50 import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
51 import Unique ( Uniquable(..) )
52 import UniqFM ( lookupUFM )
53 import Maybes ( maybeToBool, catMaybes )
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.
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 decls 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' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
88 go (fvs `plusFV` fvs') (d':ds') ds
92 %*********************************************************
94 \subsection{Value declarations}
96 %*********************************************************
99 -- rnDecl does all the work
100 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
102 rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
103 returnRn (ValD new_binds, fvs)
106 rnDecl (SigD (IfaceSig name ty id_infos loc))
108 lookupBndrRn name `thenRn` \ name' ->
109 rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) ->
110 mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
111 returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
113 doc_str = text "the interface signature for" <+> quotes (ppr name)
116 %*********************************************************
118 \subsection{Type declarations}
120 %*********************************************************
122 @rnTyDecl@ uses the `global name function' to create a new type
123 declaration in which local names have been replaced by their original
124 names, reporting any unknown names.
126 Renaming type variables is a pain. Because they now contain uniques,
127 it is necessary to pass in an association list which maps a parsed
128 tyvar to its @Name@ representation.
129 In some cases (type signatures of values),
130 it is even necessary to go over the type first
131 in order to get the set of tyvars used by it, make an assoc list,
132 and then go over it again to rename the tyvars!
133 However, we can also do some scoping checks at the same time.
136 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
137 = pushSrcLocRn src_loc $
138 lookupBndrRn tycon `thenRn` \ tycon' ->
139 bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
140 rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
141 checkDupOrQualNames data_doc con_names `thenRn_`
142 mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
143 rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
144 ASSERT(isNoDataPragmas pragmas)
145 returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls'
146 derivings' noDataPragmas src_loc),
147 cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
149 data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
150 con_names = map conDeclName condecls
152 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
153 = pushSrcLocRn src_loc $
154 lookupBndrRn name `thenRn` \ name' ->
155 bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
156 rnHsType syn_doc ty `thenRn` \ (ty', ty_fvs) ->
157 returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
159 syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
161 rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
162 tname dname snames src_loc))
163 = pushSrcLocRn src_loc $
165 lookupBndrRn cname `thenRn` \ cname' ->
167 -- Deal with the implicit tycon and datacon name
168 -- They aren't in scope (because they aren't visible to the user)
169 -- and what we want to do is simply look them up in the cache;
170 -- we jolly well ought to get a 'hit' there!
171 -- So the 'Imported' part of this call is not relevant.
172 -- Unclean; but since these two are the only place this happens
173 -- I can't work up the energy to do it more beautifully
174 mkImportedGlobalFromRdrName tname `thenRn` \ tname' ->
175 mkImportedGlobalFromRdrName dname `thenRn` \ dname' ->
176 mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' ->
178 -- Tyvars scope over bindings and context
179 bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
181 -- Check the superclasses
182 rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
184 -- Check the signatures
186 -- First process the class op sigs, then the fixity sigs.
187 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
188 (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
190 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
191 mapFvRn (rn_op cname' clas_tyvar_names) op_sigs
192 `thenRn` \ (sigs', sig_fvs) ->
193 mapRn_ (unknownSigErr) non_sigs `thenRn_`
195 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
197 renameSigs False binders lookupOccRn fix_sigs
198 `thenRn` \ (fixs', fix_fvs) ->
201 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
203 `thenRn` \ (mbinds', meth_fvs) ->
205 -- Typechecker is responsible for checking that we only
206 -- give default-method bindings for things in this class.
207 -- The renamer *could* check this for class decls, but can't
208 -- for instance decls.
210 ASSERT(isNoClassPragmas pragmas)
211 returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds'
212 NoClassPragmas tname' dname' snames' src_loc),
220 cls_doc = text "the declaration for class" <+> ppr cname
221 sig_doc = text "the signatures for class" <+> ppr cname
222 meth_doc = text "the default-methods for class" <+> ppr cname
224 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
225 meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
226 meth_rdr_names = map fst meth_rdr_names_w_locs
228 rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
229 = pushSrcLocRn locn $
230 lookupBndrRn op `thenRn` \ op_name ->
232 -- Check the signature
233 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
235 check_in_op_ty clas_tyvar =
236 checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
237 (classTyVarNotInOpTyErr clas_tyvar sig)
239 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
241 -- Make the default-method name
242 getModeRn `thenRn` \ mode ->
243 (case (mode, maybe_dm) of
245 | op `elem` meth_rdr_names
246 -> -- Source class decl with an explicit method decl
247 newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn
248 `thenRn` \ dm_name ->
249 returnRn (Just dm_name, emptyFVs)
252 -> -- Source class dec, no explicit method decl
253 returnRn (Nothing, emptyFVs)
255 (InterfaceMode, Just dm_rdr_name)
256 -> -- Imported class that has a default method decl
257 -- See comments with tname, snames, above
258 lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name ->
259 returnRn (Just dm_name, unitFV dm_name)
260 -- An imported class decl mentions, rather than defines,
261 -- the default method, so we must arrange to pull it in
263 (InterfaceMode, Nothing)
264 -- Imported class with no default metho
265 -> returnRn (Nothing, emptyFVs)
266 ) `thenRn` \ (maybe_dm_name, dm_fvs) ->
268 returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs `plusFV` dm_fvs)
272 %*********************************************************
274 \subsection{Instance declarations}
276 %*********************************************************
279 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
280 = pushSrcLocRn src_loc $
281 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
283 inst_tyvars = case inst_ty' of
284 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
286 -- (Slightly strangely) the forall-d tyvars scope over
287 -- the method bindings too
290 -- Rename the bindings
291 -- NB meth_names can be qualified!
292 checkDupNames meth_doc meth_names `thenRn_`
293 extendTyVarEnvFVRn inst_tyvars (
295 ) `thenRn` \ (mbinds', meth_fvs) ->
297 binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
299 -- Delete sigs (&report) sigs that aren't allowed inside an
305 (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
307 okInInstDecl (FixSig _) = False
308 okInInstDecl (Sig _ _ _) = False
309 okInInstDecl _ = True
312 -- You can't have fixity decls & type signatures
313 -- within an instance declaration.
314 mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
316 -- Rename the prags and signatures.
317 -- Note that the type variables are not in scope here,
318 -- so that instance Eq a => Eq (T a) where
319 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
321 renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
323 getModeRn `thenRn` \ mode ->
325 InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name ->
326 returnRn (dfun_name, unitFV dfun_name)
327 SourceMode -> newDFunName (getDFunKey inst_ty') src_loc
328 `thenRn` \ dfun_name ->
329 returnRn (dfun_name, emptyFVs)
331 `thenRn` \ (dfun_name, dfun_fv) ->
333 -- The typechecker checks that all the bindings are for the right class.
334 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
335 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
337 meth_doc = text "the bindings in an instance declaration"
338 meth_names = bagToList (collectMonoBinders mbinds)
341 %*********************************************************
343 \subsection{Default declarations}
345 %*********************************************************
348 rnDecl (DefD (DefaultDecl tys src_loc))
349 = pushSrcLocRn src_loc $
350 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
351 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
353 doc_str = text "a `default' declaration"
356 %*********************************************************
358 \subsection{Foreign declarations}
360 %*********************************************************
363 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
364 = pushSrcLocRn src_loc $
365 lookupOccRn name `thenRn` \ name' ->
367 fvs1 = case imp_exp of
368 FoImport _ | not isDyn -> emptyFVs
370 FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
373 | otherwise -> mkNameSet [name']
376 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
377 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
380 fo_decl_msg = ptext SLIT("a foreign declaration")
381 isDyn = isDynamic ext_nm
384 %*********************************************************
388 %*********************************************************
391 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
392 = pushSrcLocRn src_loc $
393 lookupOccRn var `thenRn` \ var' ->
394 rnRuleBody body `thenRn` \ (body', fvs) ->
395 returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
397 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
399 pushSrcLocRn src_loc $
401 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
402 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
403 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
405 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
406 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
407 checkRn (validRuleLhs ids lhs')
408 (badRuleLhsErr rule_name lhs') `thenRn_`
410 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
412 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
413 returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
414 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
416 doc = text "the transformation rule" <+> ptext rule_name
417 sig_tvs = extractRuleBndrsTyVars vars
419 get_var (RuleBndr v) = v
420 get_var (RuleBndrSig v _) = v
422 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
423 rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
424 returnRn (RuleBndrSig id t', fvs)
428 %*********************************************************
430 \subsection{Support code for type/data declarations}
432 %*********************************************************
435 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
437 rnDerivs Nothing -- derivs not specified
438 = returnRn (Nothing, emptyFVs)
441 = mapRn do_one clss `thenRn` \ clss' ->
442 returnRn (Just clss', mkNameSet clss')
444 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
445 checkRn (getUnique clas_name `elem` derivableClassKeys)
446 (derivingNonStdClassErr clas_name) `thenRn_`
451 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
452 conDeclName (ConDecl n _ _ _ l) = (n,l)
454 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
455 rnConDecl (ConDecl name tvs cxt details locn)
456 = pushSrcLocRn locn $
457 checkConName name `thenRn_`
458 lookupBndrRn name `thenRn` \ new_name ->
459 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
460 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
461 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
462 returnRn (ConDecl new_name new_tyvars new_context new_details locn,
463 cxt_fvs `plusFV` det_fvs)
465 doc = text "the definition of data constructor" <+> quotes (ppr name)
467 rnConDetails doc locn (VanillaCon tys)
468 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
469 returnRn (VanillaCon new_tys, fvs)
471 rnConDetails doc locn (InfixCon ty1 ty2)
472 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
473 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
474 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
476 rnConDetails doc locn (NewCon ty mb_field)
477 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
478 rn_field mb_field `thenRn` \ new_mb_field ->
479 returnRn (NewCon new_ty new_mb_field, fvs)
481 rn_field Nothing = returnRn Nothing
483 lookupBndrRn f `thenRn` \ new_f ->
484 returnRn (Just new_f)
486 rnConDetails doc locn (RecCon fields)
487 = checkDupOrQualNames doc field_names `thenRn_`
488 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
489 returnRn (RecCon new_fields, fvs)
491 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
493 rnField doc (names, ty)
494 = mapRn lookupBndrRn names `thenRn` \ new_names ->
495 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
496 returnRn ((new_names, new_ty), fvs)
498 rnBangTy doc (Banged ty)
499 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
500 returnRn (Banged new_ty, fvs)
502 rnBangTy doc (Unbanged ty)
503 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
504 returnRn (Unbanged new_ty, fvs)
506 rnBangTy doc (Unpacked ty)
507 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
508 returnRn (Unpacked new_ty, fvs)
510 -- This data decl will parse OK
512 -- treating "a" as the constructor.
513 -- It is really hard to make the parser spot this malformation.
514 -- So the renamer has to check that the constructor is legal
516 -- We can get an operator as the constructor, even in the prefix form:
517 -- data T = :% Int Int
518 -- from interface files, which always print in prefix form
521 = checkRn (isRdrDataCon name)
526 %*********************************************************
528 \subsection{Support code to rename types}
530 %*********************************************************
533 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
534 -- rnHsSigType is used for source-language type signatures,
535 -- which use *implicit* universal quantification.
536 rnHsSigType doc_str ty
537 = rnHsPolyType (text "the type signature for" <+> doc_str) ty
539 ---------------------------------------
540 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
541 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
542 -- The former is called for the top level of type sigs and function args.
544 ---------------------------------------
545 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
546 -- From source code (no kinds on tyvars)
547 -- Given the signature C => T we universally quantify
548 -- over FV(T) \ {in-scope-tyvars}
549 = getLocalNameEnv `thenRn` \ name_env ->
551 mentioned_in_tau = extractHsTyRdrTyVars ty
552 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
554 checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
555 rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
557 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
558 -- Explicit quantification.
559 -- Check that the forall'd tyvars are a subset of the
560 -- free tyvars in the tau-type part
561 -- That's only a warning... unless the tyvar is constrained by a
562 -- context in which case it's an error
564 mentioned_in_tau = extractHsTyRdrTyVars tau
565 mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
567 tv <- extractHsTyRdrTyVars 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 check ctxt `thenRn` \ maybe_ctxt' ->
592 returnRn (catMaybes maybe_ctxt')
593 -- Remove problem ones, to avoid duplicate error message.
596 | ambiguous = failWithRn Nothing (ambigErr doc ct ty)
597 | not_univ = failWithRn Nothing (univErr doc ct ty)
598 | otherwise = returnRn (Just ct)
600 ct_vars = extractHsTysRdrTyVars tys
602 ambiguous = -- All the universally-quantified tyvars in the constraint must appear in the tau ty
603 -- (will change when we get functional dependencies)
604 not (all (\ct_var -> not (ct_var `elem` forall_tyvars) || ct_var `elem` tau_vars) ct_vars)
606 not_univ = -- At least one of the tyvars in each constraint must
607 -- be universally quantified. This restriction isn't in Hugs
608 not (any (`elem` forall_tyvars) ct_vars)
611 rnForAll doc forall_tyvars ctxt ty
612 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
613 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
614 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
615 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
616 cxt_fvs `plusFV` ty_fvs)
618 ---------------------------------------
619 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
620 = addErrRn (unexpectedForAllTy ty) `thenRn_`
623 rnHsType doc (MonoTyVar tyvar)
624 = lookupOccRn tyvar `thenRn` \ tyvar' ->
625 returnRn (MonoTyVar tyvar', unitFV tyvar')
627 rnHsType doc (MonoFunTy ty1 ty2)
628 = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
629 -- Might find a for-all as the arg of a function type
630 rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
631 -- Or as the result. This happens when reading Prelude.hi
632 -- when we find return :: forall m. Monad m -> forall a. a -> m a
633 returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
635 rnHsType doc (MonoListTy ty)
636 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
637 returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
639 -- Unboxed tuples are allowed to have poly-typed arguments. These
640 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
641 rnHsType doc (MonoTupleTy tys boxed)
643 then mapFvRn (rnHsType doc) tys
644 else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) ->
645 returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
647 tup_con_name = tupleTyCon_name boxed (length tys)
649 rnHsType doc (MonoTyApp ty1 ty2)
650 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
651 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
652 returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
654 rnHsType doc (MonoDictTy clas tys)
655 = lookupOccRn clas `thenRn` \ clas' ->
656 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
657 returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
659 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
660 = bindUVarRn doc uv_rdr $ \ uv_name ->
661 rnHsType doc ty `thenRn` \ (ty', fvs) ->
662 returnRn (MonoUsgForAllTy uv_name ty',
665 rnHsType doc (MonoUsgTy usg ty)
666 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
667 rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
668 returnRn (MonoUsgTy usg' ty',
669 usg_fvs `plusFV` ty_fvs)
671 newUsg usg = case usg of
672 MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
673 MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
674 MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
675 returnRn (MonoUsVar uv_name, emptyFVs)
677 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
682 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
685 = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) ->
687 (_, dup_asserts) = removeDups cmp_assert theta
689 -- Check for duplicate assertions
690 -- If this isn't an error, then it ought to be:
691 mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
693 returnRn (theta, plusFVs fvs_s)
696 = lookupOccRn clas `thenRn` \ clas_name ->
697 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
698 returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
700 cmp_assert (c1,tys1) (c2,tys2)
701 = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
705 %*********************************************************
709 %*********************************************************
712 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
714 rnIdInfo (HsWorker worker)
715 = lookupOccRn worker `thenRn` \ worker' ->
716 returnRn (HsWorker worker', unitFV worker')
718 rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
719 returnRn (HsUnfold inline (Just expr'), fvs)
720 rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing, emptyFVs)
721 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
722 rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
723 rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs, emptyFVs)
724 rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info, emptyFVs)
725 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
726 `thenRn` \ (rule_body', fvs) ->
727 returnRn (HsSpecialise rule_body', fvs)
729 rnRuleBody (UfRuleBody str vars args rhs)
730 = rnCoreBndrs vars $ \ vars' ->
731 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
732 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
733 returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
736 @UfCore@ expressions.
739 rnCoreExpr (UfType ty)
740 = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
741 returnRn (UfType ty', fvs)
744 = lookupOccRn v `thenRn` \ v' ->
745 returnRn (UfVar v', unitFV v')
747 rnCoreExpr (UfCon con args)
748 = rnUfCon con `thenRn` \ (con', fvs1) ->
749 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
750 returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
752 rnCoreExpr (UfTuple con args)
753 = lookupOccRn con `thenRn` \ con' ->
754 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) ->
755 returnRn (UfTuple con' args', fvs `addOneFV` con')
757 rnCoreExpr (UfApp fun arg)
758 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
759 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
760 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
762 rnCoreExpr (UfCase scrut bndr alts)
763 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
764 bindCoreLocalFVRn bndr ( \ bndr' ->
765 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
766 returnRn (UfCase scrut' bndr' alts', fvs2)
767 ) `thenRn` \ (case', fvs3) ->
768 returnRn (case', fvs1 `plusFV` fvs3)
770 rnCoreExpr (UfNote note expr)
771 = rnNote note `thenRn` \ (note', fvs1) ->
772 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
773 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
775 rnCoreExpr (UfLam bndr body)
776 = rnCoreBndr bndr $ \ bndr' ->
777 rnCoreExpr body `thenRn` \ (body', fvs) ->
778 returnRn (UfLam bndr' body', fvs)
780 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
781 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
782 rnCoreBndr bndr ( \ bndr' ->
783 rnCoreExpr body `thenRn` \ (body', fvs2) ->
784 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
785 ) `thenRn` \ (result, fvs3) ->
786 returnRn (result, fvs1 `plusFV` fvs3)
788 rnCoreExpr (UfLet (UfRec pairs) body)
789 = rnCoreBndrs bndrs $ \ bndrs' ->
790 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
791 rnCoreExpr body `thenRn` \ (body', fvs2) ->
792 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
794 (bndrs, rhss) = unzip pairs
798 rnCoreBndr (UfValBinder name ty) thing_inside
799 = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
800 bindCoreLocalFVRn name ( \ name' ->
801 thing_inside (UfValBinder name' ty')
802 ) `thenRn` \ (result, fvs2) ->
803 returnRn (result, fvs1 `plusFV` fvs2)
805 doc = text "unfolding id"
807 rnCoreBndr (UfTyBinder name kind) thing_inside
808 = bindCoreLocalFVRn name $ \ name' ->
809 thing_inside (UfTyBinder name' kind)
811 rnCoreBndrs [] thing_inside = thing_inside []
812 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
813 rnCoreBndrs bs $ \ names' ->
814 thing_inside (name':names')
818 rnCoreAlt (con, bndrs, rhs)
819 = rnUfCon con `thenRn` \ (con', fvs1) ->
820 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
821 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
822 returnRn ((con', bndrs', rhs'), fvs2)
823 ) `thenRn` \ (result, fvs3) ->
824 returnRn (result, fvs1 `plusFV` fvs3)
827 = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
828 returnRn (UfCoerce ty', fvs)
830 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
831 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
832 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
836 = returnRn (UfDefault, emptyFVs)
838 rnUfCon (UfDataCon con)
839 = lookupOccRn con `thenRn` \ con' ->
840 returnRn (UfDataCon con', unitFV con')
842 rnUfCon (UfLitCon lit)
843 = returnRn (UfLitCon lit, emptyFVs)
845 rnUfCon (UfLitLitCon lit ty)
846 = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
847 returnRn (UfLitLitCon lit ty', fvs)
849 rnUfCon (UfPrimOp op)
850 = lookupOccRn op `thenRn` \ op' ->
851 returnRn (UfPrimOp op', emptyFVs)
853 rnUfCon (UfCCallOp str is_dyn casm gc)
854 = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
857 %*********************************************************
859 \subsection{Rule shapes}
861 %*********************************************************
863 Check the shape of a transformation rule LHS. Currently
864 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
865 not one of the @forall@'d variables.
868 validRuleLhs foralls lhs
871 check (HsApp e1 e2) = check e1
872 check (HsVar v) | v `notElem` foralls = True
877 %*********************************************************
881 %*********************************************************
884 derivingNonStdClassErr clas
885 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
887 classTyVarNotInOpTyErr clas_tyvar sig
888 = hang (hsep [ptext SLIT("Class type variable"),
889 quotes (ppr clas_tyvar),
890 ptext SLIT("does not appear in method signature")])
893 dupClassAssertWarn ctxt (assertion : dups)
894 = sep [hsep [ptext SLIT("Duplicate class assertion"),
895 quotes (pprClassAssertion assertion),
896 ptext SLIT("in the context:")],
897 nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
900 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
902 forAllWarn doc ty tyvar
903 | not opt_WarnUnusedMatches = returnRn ()
905 = getModeRn `thenRn` \ mode ->
908 InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
909 -- unless DEBUG is on, in which case it is slightly
910 -- informative. They can arise from mkRhsTyLam,
911 #endif -- leading to (say) f :: forall a b. [b] -> [b]
915 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
916 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
918 (ptext SLIT("In") <+> doc))
921 forAllErr doc ty tyvar
923 sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
924 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
926 (ptext SLIT("In") <+> doc))
928 univErr doc constraint ty
929 = sep [ptext SLIT("All of the type variable(s) in the constraint")
930 <+> quotes (pprClassAssertion constraint)
931 <+> ptext SLIT("are already in scope"),
932 nest 4 (ptext SLIT("At least one must be universally quantified here"))
935 (ptext SLIT("In") <+> doc)
937 ambigErr doc constraint ty
938 = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprClassAssertion constraint),
939 nest 4 (ptext SLIT("in the type:") <+> ppr ty),
940 nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
942 (ptext SLIT("In") <+> doc)
944 unexpectedForAllTy ty
945 = ptext SLIT("Unexpected forall type:") <+> ppr ty
947 badRuleLhsErr name lhs
948 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
949 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
951 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
954 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
955 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
956 ptext SLIT("does not appear on left hand side")]