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_GlasgowExts, opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
53 import Unique ( Uniquable(..) )
54 import UniqFM ( lookupUFM )
55 import ErrUtils ( Message )
56 import CStrings ( isCLabelString )
57 import Maybes ( maybeToBool, catMaybes )
61 @rnDecl@ `renames' declarations.
62 It simultaneously performs dependency analysis and precedence parsing.
63 It also does the following error checks:
66 Checks that tyvars are used properly. This includes checking
67 for undefined tyvars, and tyvars in contexts that are ambiguous.
68 (Some of this checking has now been moved to module @TcMonoType@,
69 since we don't have functional dependency information at this point.)
71 Checks that all variable occurences are defined.
73 Checks the @(..)@ etc constraints in the export list.
77 %*********************************************************
79 \subsection{Value declarations}
81 %*********************************************************
84 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
85 -- The decls get reversed, but that's ok
88 = go emptyFVs [] decls
90 -- Fixity decls have been dealt with already; ignore them
91 go fvs ds' [] = returnRn (ds', fvs)
92 go fvs ds' (FixD _:ds) = go fvs ds' ds
93 go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
94 go (fvs `plusFV` fvs') (d':ds') ds
98 %*********************************************************
100 \subsection{Value declarations}
102 %*********************************************************
105 -- rnDecl does all the work
106 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
108 rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
109 returnRn (ValD new_binds, fvs)
112 rnDecl (SigD (IfaceSig name ty id_infos loc))
114 lookupBndrRn name `thenRn` \ name' ->
115 rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) ->
116 mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
117 returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
119 doc_str = text "the interface signature for" <+> quotes (ppr name)
122 %*********************************************************
124 \subsection{Type declarations}
126 %*********************************************************
128 @rnTyDecl@ uses the `global name function' to create a new type
129 declaration in which local names have been replaced by their original
130 names, reporting any unknown names.
132 Renaming type variables is a pain. Because they now contain uniques,
133 it is necessary to pass in an association list which maps a parsed
134 tyvar to its @Name@ representation.
135 In some cases (type signatures of values),
136 it is even necessary to go over the type first
137 in order to get the set of tyvars used by it, make an assoc list,
138 and then go over it again to rename the tyvars!
139 However, we can also do some scoping checks at the same time.
142 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
143 = pushSrcLocRn src_loc $
144 lookupBndrRn tycon `thenRn` \ tycon' ->
145 bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
146 rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
147 checkDupOrQualNames data_doc con_names `thenRn_`
148 mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
149 rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
150 ASSERT(isNoDataPragmas pragmas)
151 returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls'
152 derivings' noDataPragmas src_loc),
153 cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
155 data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
156 con_names = map conDeclName condecls
158 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
159 = pushSrcLocRn src_loc $
160 lookupBndrRn name `thenRn` \ name' ->
161 bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
162 rnHsPolyType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) ->
163 returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
165 syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
167 -- For H98 we do *not* universally quantify on the RHS of a synonym
168 -- Silently discard context... but the tyvars in the rest won't be in scope
169 unquantify (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty
172 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
173 tname dname dwname snames src_loc))
174 = pushSrcLocRn src_loc $
176 lookupBndrRn cname `thenRn` \ cname' ->
178 -- Deal with the implicit tycon and datacon name
179 -- They aren't in scope (because they aren't visible to the user)
180 -- and what we want to do is simply look them up in the cache;
181 -- we jolly well ought to get a 'hit' there!
182 -- So the 'Imported' part of this call is not relevant.
183 -- Unclean; but since these two are the only place this happens
184 -- I can't work up the energy to do it more beautifully
185 mkImportedGlobalFromRdrName tname `thenRn` \ tname' ->
186 mkImportedGlobalFromRdrName dname `thenRn` \ dname' ->
187 mkImportedGlobalFromRdrName dwname `thenRn` \ dwname' ->
188 mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' ->
190 -- Tyvars scope over bindings and context
191 bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
193 -- Check the superclasses
194 rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
196 -- Check the functional dependencies
197 rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
199 -- Check the signatures
201 -- First process the class op sigs, then the fixity sigs.
202 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
203 (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
205 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
206 mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs
207 `thenRn` \ (sigs', sig_fvs) ->
208 mapRn_ (unknownSigErr) non_sigs `thenRn_`
210 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
212 renameSigs False binders lookupOccRn fix_sigs
213 `thenRn` \ (fixs', fix_fvs) ->
216 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
218 `thenRn` \ (mbinds', meth_fvs) ->
220 -- Typechecker is responsible for checking that we only
221 -- give default-method bindings for things in this class.
222 -- The renamer *could* check this for class decls, but can't
223 -- for instance decls.
225 ASSERT(isNoClassPragmas pragmas)
226 returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
227 NoClassPragmas tname' dname' dwname' snames' src_loc),
236 cls_doc = text "the declaration for class" <+> ppr cname
237 sig_doc = text "the signatures for class" <+> ppr cname
238 meth_doc = text "the default-methods for class" <+> ppr cname
240 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
241 meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
242 meth_rdr_names = map fst meth_rdr_names_w_locs
244 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
245 = pushSrcLocRn locn $
246 lookupBndrRn op `thenRn` \ op_name ->
248 -- Check the signature
249 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
251 check_in_op_ty clas_tyvar =
252 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
253 (classTyVarNotInOpTyErr clas_tyvar sig)
255 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
257 -- Make the default-method name
258 getModeRn `thenRn` \ mode ->
260 SourceMode -> -- Source class decl
261 newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name ->
262 returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
265 -> -- Imported class that has a default method decl
266 -- See comments with tname, snames, above
267 lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name ->
268 returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
269 -- An imported class decl for a class decl that had an explicit default
270 -- method, mentions, rather than defines,
271 -- the default method, so we must arrange to pull it in
272 ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
274 returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
278 %*********************************************************
280 \subsection{Instance declarations}
282 %*********************************************************
285 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
286 = pushSrcLocRn src_loc $
287 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
289 inst_tyvars = case inst_ty' of
290 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
292 -- (Slightly strangely) the forall-d tyvars scope over
293 -- the method bindings too
296 -- Rename the bindings
297 -- NB meth_names can be qualified!
298 checkDupNames meth_doc meth_names `thenRn_`
299 extendTyVarEnvFVRn inst_tyvars (
301 ) `thenRn` \ (mbinds', meth_fvs) ->
303 binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
305 -- Delete sigs (&report) sigs that aren't allowed inside an
311 (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
313 okInInstDecl (FixSig _) = False
314 okInInstDecl (Sig _ _ _) = False
315 okInInstDecl _ = True
318 -- You can't have fixity decls & type signatures
319 -- within an instance declaration.
320 mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
322 -- Rename the prags and signatures.
323 -- Note that the type variables are not in scope here,
324 -- so that instance Eq a => Eq (T a) where
325 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
327 renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
329 getModeRn `thenRn` \ mode ->
331 InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name ->
332 returnRn (dfun_name, unitFV dfun_name)
333 SourceMode -> newDFunName (getDFunKey inst_ty') src_loc
334 `thenRn` \ dfun_name ->
335 returnRn (dfun_name, emptyFVs)
337 `thenRn` \ (dfun_name, dfun_fv) ->
339 -- The typechecker checks that all the bindings are for the right class.
340 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
341 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
343 meth_doc = text "the bindings in an instance declaration"
344 meth_names = bagToList (collectMonoBinders mbinds)
347 %*********************************************************
349 \subsection{Default declarations}
351 %*********************************************************
354 rnDecl (DefD (DefaultDecl tys src_loc))
355 = pushSrcLocRn src_loc $
356 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
357 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
359 doc_str = text "a `default' declaration"
362 %*********************************************************
364 \subsection{Foreign declarations}
366 %*********************************************************
369 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
370 = pushSrcLocRn src_loc $
371 lookupOccRn name `thenRn` \ name' ->
373 ok_ext_nm Dynamic = True
374 ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
375 ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
377 fvs1 = case imp_exp of
378 FoImport _ | not isDyn -> emptyFVs
380 FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
383 | otherwise -> mkNameSet [name']
386 checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
387 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
388 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
391 fo_decl_msg = ptext SLIT("a foreign declaration")
392 isDyn = isDynamicExtName ext_nm
395 %*********************************************************
399 %*********************************************************
402 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
403 = pushSrcLocRn src_loc $
404 lookupOccRn var `thenRn` \ var' ->
405 rnRuleBody body `thenRn` \ (body', fvs) ->
406 returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
408 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
410 pushSrcLocRn src_loc $
412 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
413 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
414 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
416 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
417 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
418 checkRn (validRuleLhs ids lhs')
419 (badRuleLhsErr rule_name lhs') `thenRn_`
421 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
423 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
424 returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
425 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
427 doc = text "the transformation rule" <+> ptext rule_name
428 sig_tvs = extractRuleBndrsTyVars vars
430 get_var (RuleBndr v) = v
431 get_var (RuleBndrSig v _) = v
433 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
434 rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
435 returnRn (RuleBndrSig id t', fvs)
439 %*********************************************************
441 \subsection{Support code for type/data declarations}
443 %*********************************************************
446 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
448 rnDerivs Nothing -- derivs not specified
449 = returnRn (Nothing, emptyFVs)
452 = mapRn do_one clss `thenRn` \ clss' ->
453 returnRn (Just clss', mkNameSet clss')
455 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
456 checkRn (getUnique clas_name `elem` derivableClassKeys)
457 (derivingNonStdClassErr clas_name) `thenRn_`
462 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
463 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
465 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
466 rnConDecl (ConDecl name wkr tvs cxt details locn)
467 = pushSrcLocRn locn $
468 checkConName name `thenRn_`
469 lookupBndrRn name `thenRn` \ new_name ->
471 mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr ->
472 -- See comments with ClassDecl
474 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
475 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
476 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
477 returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
478 cxt_fvs `plusFV` det_fvs)
480 doc = text "the definition of data constructor" <+> quotes (ppr name)
482 rnConDetails doc locn (VanillaCon tys)
483 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
484 returnRn (VanillaCon new_tys, fvs)
486 rnConDetails doc locn (InfixCon ty1 ty2)
487 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
488 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
489 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
491 rnConDetails doc locn (NewCon ty mb_field)
492 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
493 rn_field mb_field `thenRn` \ new_mb_field ->
494 returnRn (NewCon new_ty new_mb_field, fvs)
496 rn_field Nothing = returnRn Nothing
498 lookupBndrRn f `thenRn` \ new_f ->
499 returnRn (Just new_f)
501 rnConDetails doc locn (RecCon fields)
502 = checkDupOrQualNames doc field_names `thenRn_`
503 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
504 returnRn (RecCon new_fields, fvs)
506 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
508 rnField doc (names, ty)
509 = mapRn lookupBndrRn names `thenRn` \ new_names ->
510 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
511 returnRn ((new_names, new_ty), fvs)
513 rnBangTy doc (Banged ty)
514 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
515 returnRn (Banged new_ty, fvs)
517 rnBangTy doc (Unbanged ty)
518 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
519 returnRn (Unbanged new_ty, fvs)
521 rnBangTy doc (Unpacked ty)
522 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
523 returnRn (Unpacked new_ty, fvs)
525 -- This data decl will parse OK
527 -- treating "a" as the constructor.
528 -- It is really hard to make the parser spot this malformation.
529 -- So the renamer has to check that the constructor is legal
531 -- We can get an operator as the constructor, even in the prefix form:
532 -- data T = :% Int Int
533 -- from interface files, which always print in prefix form
536 = checkRn (isRdrDataCon name)
541 %*********************************************************
543 \subsection{Support code to rename types}
545 %*********************************************************
548 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
549 -- rnHsSigType is used for source-language type signatures,
550 -- which use *implicit* universal quantification.
551 rnHsSigType doc_str ty
552 = rnHsPolyType (text "the type signature for" <+> doc_str) ty
554 ---------------------------------------
555 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
556 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
557 -- The former is called for the top level of type sigs and function args.
559 ---------------------------------------
560 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
561 -- Implicit quantifiction in source code (no kinds on tyvars)
562 -- Given the signature C => T we universally quantify
563 -- over FV(T) \ {in-scope-tyvars}
564 = getLocalNameEnv `thenRn` \ name_env ->
566 mentioned_in_tau = extractHsTyRdrTyVars ty
567 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
569 checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
570 rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
572 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
573 -- Explicit quantification.
574 -- Check that the forall'd tyvars are a subset of the
575 -- free tyvars in the tau-type part
576 -- That's only a warning... unless the tyvar is constrained by a
577 -- context in which case it's an error
579 mentioned_in_tau = extractHsTyRdrTyVars tau
580 mentioned_in_ctxt = nub [tv | p <- ctxt,
582 tv <- extractHsTyRdrTyVars ty]
583 tys_of_pred (HsPClass clas tys) = tys
584 tys_of_pred (HsPIParam n ty) = [ty]
586 dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
587 -- dubious = explicitly quantified but not mentioned in tau type
589 (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
590 -- bad = explicitly quantified and constrained, but not mentioned in tau
591 -- warn = explicitly quantified but not mentioned in ctxt or tau
593 forall_tyvar_names = map getTyVarName forall_tyvars
595 -- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
596 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
597 checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
598 rnForAll doc forall_tyvars ctxt' tau
600 rnHsPolyType doc other_ty = rnHsType doc other_ty
603 -- Check that each constraint mentions at least one of the forall'd type variables
604 -- Since the forall'd type variables are a subset of the free tyvars
605 -- of the tau-type part, this guarantees that every constraint mentions
606 -- at least one of the free tyvars in ty
607 checkConstraints doc forall_tyvars tau_vars ctxt ty
608 = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
609 returnRn (catMaybes maybe_ctxt')
610 -- Remove problem ones, to avoid duplicate error message.
612 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
613 | not_univ = failWithRn Nothing (univErr doc p ty)
614 | otherwise = returnRn (Just p)
616 ct_vars = extractHsTysRdrTyVars tys
617 not_univ = -- At least one of the tyvars in each constraint must
618 -- be universally quantified. This restriction isn't in Hugs
619 not (any (`elem` forall_tyvars) ct_vars)
620 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
623 rnForAll doc forall_tyvars ctxt ty
624 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
625 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
626 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
627 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
628 cxt_fvs `plusFV` ty_fvs)
630 ---------------------------------------
631 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
632 = addWarnRn (unexpectedForAllTy ty) `thenRn_`
635 rnHsType doc (MonoTyVar tyvar)
636 = lookupOccRn tyvar `thenRn` \ tyvar' ->
637 returnRn (MonoTyVar tyvar', unitFV tyvar')
639 rnHsType doc (MonoFunTy ty1 ty2)
640 = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
641 -- Might find a for-all as the arg of a function type
642 rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
643 -- Or as the result. This happens when reading Prelude.hi
644 -- when we find return :: forall m. Monad m -> forall a. a -> m a
645 returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
647 rnHsType doc (MonoListTy ty)
648 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
649 returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
651 -- Unboxed tuples are allowed to have poly-typed arguments. These
652 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
653 rnHsType doc (MonoTupleTy tys boxed)
655 then mapFvRn (rnHsType doc) tys
656 else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) ->
657 returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
659 tup_con_name = tupleTyCon_name boxed (length tys)
661 rnHsType doc (MonoTyApp ty1 ty2)
662 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
663 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
664 returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
666 rnHsType doc (MonoIParamTy n ty)
667 = getIPName n `thenRn` \ name ->
668 rnHsType doc ty `thenRn` \ (ty', fvs) ->
669 returnRn (MonoIParamTy name ty', fvs)
671 rnHsType doc (MonoDictTy clas tys)
672 = lookupOccRn clas `thenRn` \ clas' ->
673 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
674 returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
676 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
677 = bindUVarRn doc uv_rdr $ \ uv_name ->
678 rnHsType doc ty `thenRn` \ (ty', fvs) ->
679 returnRn (MonoUsgForAllTy uv_name ty',
682 rnHsType doc (MonoUsgTy usg ty)
683 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
684 rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) ->
685 -- A for-all can occur inside a usage annotation
686 returnRn (MonoUsgTy usg' ty',
687 usg_fvs `plusFV` ty_fvs)
689 newUsg usg = case usg of
690 MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
691 MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
692 MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
693 returnRn (MonoUsVar uv_name, emptyFVs)
695 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
700 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
703 = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
705 (_, dup_asserts) = removeDups (cmpHsPred compare) theta
707 -- Check for duplicate assertions
708 -- If this isn't an error, then it ought to be:
709 mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
711 returnRn (theta, plusFVs fvs_s)
713 rnPred doc (HsPClass clas tys)
714 = lookupOccRn clas `thenRn` \ clas_name ->
715 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
716 returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
717 rnPred doc (HsPIParam n ty)
718 = getIPName n `thenRn` \ name ->
719 rnHsType doc ty `thenRn` \ (ty', fvs) ->
720 returnRn (HsPIParam name ty', fvs)
724 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
727 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
728 returnRn (theta, plusFVs fvs_s)
731 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
732 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
733 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
735 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
737 = lookupOccRn tyvar `thenRn` \ tyvar' ->
738 returnRn (tyvar', unitFV tyvar')
741 %*********************************************************
745 %*********************************************************
748 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
750 rnIdInfo (HsWorker worker)
751 = lookupOccRn worker `thenRn` \ worker' ->
752 returnRn (HsWorker worker', unitFV worker')
754 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
755 returnRn (HsUnfold inline expr', fvs)
756 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
757 rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
758 rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
759 rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
760 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
761 `thenRn` \ (rule_body', fvs) ->
762 returnRn (HsSpecialise rule_body', fvs)
764 rnRuleBody (UfRuleBody str vars args rhs)
765 = rnCoreBndrs vars $ \ vars' ->
766 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
767 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
768 returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
771 @UfCore@ expressions.
774 rnCoreExpr (UfType ty)
775 = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
776 returnRn (UfType ty', fvs)
779 = lookupOccRn v `thenRn` \ v' ->
780 returnRn (UfVar v', unitFV v')
783 = returnRn (UfLit l, emptyFVs)
785 rnCoreExpr (UfLitLit l ty)
786 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
787 returnRn (UfLitLit l ty', fvs)
789 rnCoreExpr (UfCCall cc ty)
790 = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) ->
791 returnRn (UfCCall cc ty', fvs)
793 rnCoreExpr (UfTuple con args)
794 = lookupOccRn con `thenRn` \ con' ->
795 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) ->
796 returnRn (UfTuple con' args', fvs `addOneFV` con')
798 rnCoreExpr (UfApp fun arg)
799 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
800 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
801 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
803 rnCoreExpr (UfCase scrut bndr alts)
804 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
805 bindCoreLocalFVRn bndr ( \ bndr' ->
806 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
807 returnRn (UfCase scrut' bndr' alts', fvs2)
808 ) `thenRn` \ (case', fvs3) ->
809 returnRn (case', fvs1 `plusFV` fvs3)
811 rnCoreExpr (UfNote note expr)
812 = rnNote note `thenRn` \ (note', fvs1) ->
813 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
814 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
816 rnCoreExpr (UfLam bndr body)
817 = rnCoreBndr bndr $ \ bndr' ->
818 rnCoreExpr body `thenRn` \ (body', fvs) ->
819 returnRn (UfLam bndr' body', fvs)
821 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
822 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
823 rnCoreBndr bndr ( \ bndr' ->
824 rnCoreExpr body `thenRn` \ (body', fvs2) ->
825 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
826 ) `thenRn` \ (result, fvs3) ->
827 returnRn (result, fvs1 `plusFV` fvs3)
829 rnCoreExpr (UfLet (UfRec pairs) body)
830 = rnCoreBndrs bndrs $ \ bndrs' ->
831 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
832 rnCoreExpr body `thenRn` \ (body', fvs2) ->
833 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
835 (bndrs, rhss) = unzip pairs
839 rnCoreBndr (UfValBinder name ty) thing_inside
840 = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
841 bindCoreLocalFVRn name ( \ name' ->
842 thing_inside (UfValBinder name' ty')
843 ) `thenRn` \ (result, fvs2) ->
844 returnRn (result, fvs1 `plusFV` fvs2)
846 doc = text "unfolding id"
848 rnCoreBndr (UfTyBinder name kind) thing_inside
849 = bindCoreLocalFVRn name $ \ name' ->
850 thing_inside (UfTyBinder name' kind)
852 rnCoreBndrs [] thing_inside = thing_inside []
853 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
854 rnCoreBndrs bs $ \ names' ->
855 thing_inside (name':names')
859 rnCoreAlt (con, bndrs, rhs)
860 = rnUfCon con `thenRn` \ (con', fvs1) ->
861 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
862 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
863 returnRn ((con', bndrs', rhs'), fvs2)
864 ) `thenRn` \ (result, fvs3) ->
865 returnRn (result, fvs1 `plusFV` fvs3)
868 = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
869 returnRn (UfCoerce ty', fvs)
871 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
872 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
873 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
877 = returnRn (UfDefault, emptyFVs)
879 rnUfCon (UfDataAlt con)
880 = lookupOccRn con `thenRn` \ con' ->
881 returnRn (UfDataAlt con', unitFV con')
883 rnUfCon (UfLitAlt lit)
884 = returnRn (UfLitAlt lit, emptyFVs)
886 rnUfCon (UfLitLitAlt lit ty)
887 = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
888 returnRn (UfLitLitAlt lit ty', fvs)
891 %*********************************************************
893 \subsection{Rule shapes}
895 %*********************************************************
897 Check the shape of a transformation rule LHS. Currently
898 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
899 not one of the @forall@'d variables.
902 validRuleLhs foralls lhs
905 check (HsApp e1 e2) = check e1
906 check (HsVar v) | v `notElem` foralls = True
911 %*********************************************************
915 %*********************************************************
918 derivingNonStdClassErr clas
919 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
921 classTyVarNotInOpTyErr clas_tyvar sig
922 = hang (hsep [ptext SLIT("Class type variable"),
923 quotes (ppr clas_tyvar),
924 ptext SLIT("does not appear in method signature")])
927 dupClassAssertWarn ctxt (assertion : dups)
928 = sep [hsep [ptext SLIT("Duplicate class assertion"),
929 quotes (pprHsPred assertion),
930 ptext SLIT("in the context:")],
931 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
934 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
936 forAllWarn doc ty tyvar
937 | not opt_WarnUnusedMatches = returnRn ()
939 = getModeRn `thenRn` \ mode ->
942 InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
943 -- unless DEBUG is on, in which case it is slightly
944 -- informative. They can arise from mkRhsTyLam,
945 #endif -- leading to (say) f :: forall a b. [b] -> [b]
949 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
950 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
952 (ptext SLIT("In") <+> doc))
955 forAllErr doc ty tyvar
957 sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
958 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
960 (ptext SLIT("In") <+> doc))
962 univErr doc constraint ty
963 = sep [ptext SLIT("All of the type variable(s) in the constraint")
964 <+> quotes (pprHsPred constraint)
965 <+> ptext SLIT("are already in scope"),
966 nest 4 (ptext SLIT("At least one must be universally quantified here"))
969 (ptext SLIT("In") <+> doc)
971 ambigErr doc constraint ty
972 = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
973 nest 4 (ptext SLIT("in the type:") <+> ppr ty),
974 nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
976 (ptext SLIT("In") <+> doc)
978 unexpectedForAllTy ty
979 = ptext SLIT("Unexpected forall type:") <+> ppr ty
981 badRuleLhsErr name lhs
982 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
983 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
985 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
988 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
989 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
990 ptext SLIT("does not appear on left hand side")]
992 badExtName :: ExtName -> Message
994 = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]