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
204 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
205 mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
207 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
209 renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
212 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
214 `thenRn` \ (mbinds', meth_fvs) ->
216 -- Typechecker is responsible for checking that we only
217 -- give default-method bindings for things in this class.
218 -- The renamer *could* check this for class decls, but can't
219 -- for instance decls.
221 ASSERT(isNoClassPragmas pragmas)
222 returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
223 NoClassPragmas tname' dname' dwname' snames' src_loc),
232 cls_doc = text "the declaration for class" <+> ppr cname
233 sig_doc = text "the signatures for class" <+> ppr cname
234 meth_doc = text "the default-methods for class" <+> ppr cname
236 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
237 meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
238 meth_rdr_names = map fst meth_rdr_names_w_locs
240 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
241 = pushSrcLocRn locn $
242 lookupBndrRn op `thenRn` \ op_name ->
244 -- Check the signature
245 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
247 check_in_op_ty clas_tyvar =
248 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
249 (classTyVarNotInOpTyErr clas_tyvar sig)
251 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
253 -- Make the default-method name
254 getModeRn `thenRn` \ mode ->
256 SourceMode -> -- Source class decl
257 newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name ->
258 returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
261 -> -- Imported class that has a default method decl
262 -- See comments with tname, snames, above
263 lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name ->
264 returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
265 -- An imported class decl for a class decl that had an explicit default
266 -- method, mentions, rather than defines,
267 -- the default method, so we must arrange to pull it in
268 ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
270 returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
274 %*********************************************************
276 \subsection{Instance declarations}
278 %*********************************************************
281 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
282 = pushSrcLocRn src_loc $
283 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
285 inst_tyvars = case inst_ty' of
286 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
288 -- (Slightly strangely) the forall-d tyvars scope over
289 -- the method bindings too
292 -- Rename the bindings
293 -- NB meth_names can be qualified!
294 checkDupNames meth_doc meth_names `thenRn_`
295 extendTyVarEnvFVRn inst_tyvars (
297 ) `thenRn` \ (mbinds', meth_fvs) ->
299 binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
301 -- Rename the prags and signatures.
302 -- Note that the type variables are not in scope here,
303 -- so that instance Eq a => Eq (T a) where
304 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
306 renameSigs (okInstDclSig binders) uprags `thenRn` \ (new_uprags, prag_fvs) ->
308 getModeRn `thenRn` \ mode ->
310 InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name ->
311 returnRn (dfun_name, unitFV dfun_name)
312 SourceMode -> newDFunName (getDFunKey inst_ty') src_loc
313 `thenRn` \ dfun_name ->
314 returnRn (dfun_name, emptyFVs)
316 `thenRn` \ (dfun_name, dfun_fv) ->
318 -- The typechecker checks that all the bindings are for the right class.
319 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
320 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
322 meth_doc = text "the bindings in an instance declaration"
323 meth_names = bagToList (collectMonoBinders mbinds)
326 %*********************************************************
328 \subsection{Default declarations}
330 %*********************************************************
333 rnDecl (DefD (DefaultDecl tys src_loc))
334 = pushSrcLocRn src_loc $
335 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
336 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
338 doc_str = text "a `default' declaration"
341 %*********************************************************
343 \subsection{Foreign declarations}
345 %*********************************************************
348 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
349 = pushSrcLocRn src_loc $
350 lookupOccRn name `thenRn` \ name' ->
352 ok_ext_nm Dynamic = True
353 ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
354 ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
356 fvs1 = case imp_exp of
357 FoImport _ | not isDyn -> emptyFVs
359 FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
362 | otherwise -> mkNameSet [name']
365 checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
366 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
367 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
370 fo_decl_msg = ptext SLIT("a foreign declaration")
371 isDyn = isDynamicExtName ext_nm
374 %*********************************************************
378 %*********************************************************
381 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
382 = pushSrcLocRn src_loc $
383 lookupOccRn var `thenRn` \ var' ->
384 rnRuleBody body `thenRn` \ (body', fvs) ->
385 returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
387 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
389 pushSrcLocRn src_loc $
391 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
392 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
393 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
395 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
396 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
397 checkRn (validRuleLhs ids lhs')
398 (badRuleLhsErr rule_name lhs') `thenRn_`
400 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
402 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
403 returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
404 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
406 doc = text "the transformation rule" <+> ptext rule_name
407 sig_tvs = extractRuleBndrsTyVars vars
409 get_var (RuleBndr v) = v
410 get_var (RuleBndrSig v _) = v
412 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
413 rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
414 returnRn (RuleBndrSig id t', fvs)
418 %*********************************************************
420 \subsection{Support code for type/data declarations}
422 %*********************************************************
425 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
427 rnDerivs Nothing -- derivs not specified
428 = returnRn (Nothing, emptyFVs)
431 = mapRn do_one clss `thenRn` \ clss' ->
432 returnRn (Just clss', mkNameSet clss')
434 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
435 checkRn (getUnique clas_name `elem` derivableClassKeys)
436 (derivingNonStdClassErr clas_name) `thenRn_`
441 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
442 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
444 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
445 rnConDecl (ConDecl name wkr tvs cxt details locn)
446 = pushSrcLocRn locn $
447 checkConName name `thenRn_`
448 lookupBndrRn name `thenRn` \ new_name ->
450 mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr ->
451 -- See comments with ClassDecl
453 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
454 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
455 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
456 returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
457 cxt_fvs `plusFV` det_fvs)
459 doc = text "the definition of data constructor" <+> quotes (ppr name)
461 rnConDetails doc locn (VanillaCon tys)
462 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
463 returnRn (VanillaCon new_tys, fvs)
465 rnConDetails doc locn (InfixCon ty1 ty2)
466 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
467 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
468 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
470 rnConDetails doc locn (NewCon ty mb_field)
471 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
472 rn_field mb_field `thenRn` \ new_mb_field ->
473 returnRn (NewCon new_ty new_mb_field, fvs)
475 rn_field Nothing = returnRn Nothing
477 lookupBndrRn f `thenRn` \ new_f ->
478 returnRn (Just new_f)
480 rnConDetails doc locn (RecCon fields)
481 = checkDupOrQualNames doc field_names `thenRn_`
482 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
483 returnRn (RecCon new_fields, fvs)
485 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
487 rnField doc (names, ty)
488 = mapRn lookupBndrRn names `thenRn` \ new_names ->
489 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
490 returnRn ((new_names, new_ty), fvs)
492 rnBangTy doc (Banged ty)
493 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
494 returnRn (Banged new_ty, fvs)
496 rnBangTy doc (Unbanged ty)
497 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
498 returnRn (Unbanged new_ty, fvs)
500 rnBangTy doc (Unpacked ty)
501 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
502 returnRn (Unpacked new_ty, fvs)
504 -- This data decl will parse OK
506 -- treating "a" as the constructor.
507 -- It is really hard to make the parser spot this malformation.
508 -- So the renamer has to check that the constructor is legal
510 -- We can get an operator as the constructor, even in the prefix form:
511 -- data T = :% Int Int
512 -- from interface files, which always print in prefix form
515 = checkRn (isRdrDataCon name)
520 %*********************************************************
522 \subsection{Support code to rename types}
524 %*********************************************************
527 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
528 -- rnHsSigType is used for source-language type signatures,
529 -- which use *implicit* universal quantification.
530 rnHsSigType doc_str ty
531 = rnHsPolyType (text "the type signature for" <+> doc_str) ty
533 ---------------------------------------
534 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
535 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
536 -- The former is called for the top level of type sigs and function args.
538 ---------------------------------------
539 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
540 -- Implicit quantifiction in source code (no kinds on tyvars)
541 -- Given the signature C => T we universally quantify
542 -- over FV(T) \ {in-scope-tyvars}
543 = getLocalNameEnv `thenRn` \ name_env ->
545 mentioned_in_tau = extractHsTyRdrTyVars ty
546 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
548 checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
549 rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
551 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
552 -- Explicit quantification.
553 -- Check that the forall'd tyvars are a subset of the
554 -- free tyvars in the tau-type part
555 -- That's only a warning... unless the tyvar is constrained by a
556 -- context in which case it's an error
558 mentioned_in_tau = extractHsTyRdrTyVars tau
559 mentioned_in_ctxt = nub [tv | p <- ctxt,
561 tv <- extractHsTyRdrTyVars ty]
562 tys_of_pred (HsPClass clas tys) = tys
563 tys_of_pred (HsPIParam n ty) = [ty]
565 dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
566 -- dubious = explicitly quantified but not mentioned in tau type
568 (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
569 -- bad = explicitly quantified and constrained, but not mentioned in tau
570 -- warn = explicitly quantified but not mentioned in ctxt or tau
572 forall_tyvar_names = map getTyVarName forall_tyvars
574 -- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
575 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
576 checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
577 rnForAll doc forall_tyvars ctxt' tau
579 rnHsPolyType doc other_ty = rnHsType doc other_ty
582 -- Check that each constraint mentions at least one of the forall'd type variables
583 -- Since the forall'd type variables are a subset of the free tyvars
584 -- of the tau-type part, this guarantees that every constraint mentions
585 -- at least one of the free tyvars in ty
586 checkConstraints doc forall_tyvars tau_vars ctxt ty
587 = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
588 returnRn (catMaybes maybe_ctxt')
589 -- Remove problem ones, to avoid duplicate error message.
591 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
592 | not_univ = failWithRn Nothing (univErr doc p ty)
593 | otherwise = returnRn (Just p)
595 ct_vars = extractHsTysRdrTyVars tys
596 not_univ = -- At least one of the tyvars in each constraint must
597 -- be universally quantified. This restriction isn't in Hugs
598 not (any (`elem` forall_tyvars) ct_vars)
599 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
602 rnForAll doc forall_tyvars ctxt ty
603 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
604 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
605 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
606 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
607 cxt_fvs `plusFV` ty_fvs)
609 ---------------------------------------
610 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
611 = addWarnRn (unexpectedForAllTy ty) `thenRn_`
614 rnHsType doc (MonoTyVar tyvar)
615 = lookupOccRn tyvar `thenRn` \ tyvar' ->
616 returnRn (MonoTyVar tyvar', unitFV tyvar')
618 rnHsType doc (MonoFunTy ty1 ty2)
619 = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
620 -- Might find a for-all as the arg of a function type
621 rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
622 -- Or as the result. This happens when reading Prelude.hi
623 -- when we find return :: forall m. Monad m -> forall a. a -> m a
624 returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
626 rnHsType doc (MonoListTy ty)
627 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
628 returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
630 -- Unboxed tuples are allowed to have poly-typed arguments. These
631 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
632 rnHsType doc (MonoTupleTy tys boxed)
634 then mapFvRn (rnHsType doc) tys
635 else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) ->
636 returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
638 tup_con_name = tupleTyCon_name boxed (length tys)
640 rnHsType doc (MonoTyApp ty1 ty2)
641 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
642 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
643 returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
645 rnHsType doc (MonoIParamTy n ty)
646 = getIPName n `thenRn` \ name ->
647 rnHsType doc ty `thenRn` \ (ty', fvs) ->
648 returnRn (MonoIParamTy name ty', fvs)
650 rnHsType doc (MonoDictTy clas tys)
651 = lookupOccRn clas `thenRn` \ clas' ->
652 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
653 returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
655 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
656 = bindUVarRn doc uv_rdr $ \ uv_name ->
657 rnHsType doc ty `thenRn` \ (ty', fvs) ->
658 returnRn (MonoUsgForAllTy uv_name ty',
661 rnHsType doc (MonoUsgTy usg ty)
662 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
663 rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) ->
664 -- A for-all can occur inside a usage annotation
665 returnRn (MonoUsgTy usg' ty',
666 usg_fvs `plusFV` ty_fvs)
668 newUsg usg = case usg of
669 MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
670 MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
671 MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
672 returnRn (MonoUsVar uv_name, emptyFVs)
674 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
679 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
682 = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
684 (_, dup_asserts) = removeDups (cmpHsPred compare) theta
686 -- Check for duplicate assertions
687 -- If this isn't an error, then it ought to be:
688 mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
690 returnRn (theta, plusFVs fvs_s)
692 rnPred doc (HsPClass clas tys)
693 = lookupOccRn clas `thenRn` \ clas_name ->
694 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
695 returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
696 rnPred doc (HsPIParam n ty)
697 = getIPName n `thenRn` \ name ->
698 rnHsType doc ty `thenRn` \ (ty', fvs) ->
699 returnRn (HsPIParam name ty', fvs)
703 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
706 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
707 returnRn (theta, plusFVs fvs_s)
710 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
711 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
712 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
714 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
716 = lookupOccRn tyvar `thenRn` \ tyvar' ->
717 returnRn (tyvar', unitFV tyvar')
720 %*********************************************************
724 %*********************************************************
727 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
729 rnIdInfo (HsWorker worker)
730 = lookupOccRn worker `thenRn` \ worker' ->
731 returnRn (HsWorker worker', unitFV worker')
733 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
734 returnRn (HsUnfold inline expr', fvs)
735 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
736 rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
737 rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
738 rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
739 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
740 `thenRn` \ (rule_body', fvs) ->
741 returnRn (HsSpecialise rule_body', fvs)
743 rnRuleBody (UfRuleBody str vars args rhs)
744 = rnCoreBndrs vars $ \ vars' ->
745 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
746 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
747 returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
750 @UfCore@ expressions.
753 rnCoreExpr (UfType ty)
754 = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
755 returnRn (UfType ty', fvs)
758 = lookupOccRn v `thenRn` \ v' ->
759 returnRn (UfVar v', unitFV v')
762 = returnRn (UfLit l, emptyFVs)
764 rnCoreExpr (UfLitLit l ty)
765 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
766 returnRn (UfLitLit l ty', fvs)
768 rnCoreExpr (UfCCall cc ty)
769 = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) ->
770 returnRn (UfCCall cc ty', fvs)
772 rnCoreExpr (UfTuple con args)
773 = lookupOccRn con `thenRn` \ con' ->
774 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) ->
775 returnRn (UfTuple con' args', fvs `addOneFV` con')
777 rnCoreExpr (UfApp fun arg)
778 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
779 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
780 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
782 rnCoreExpr (UfCase scrut bndr alts)
783 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
784 bindCoreLocalFVRn bndr ( \ bndr' ->
785 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
786 returnRn (UfCase scrut' bndr' alts', fvs2)
787 ) `thenRn` \ (case', fvs3) ->
788 returnRn (case', fvs1 `plusFV` fvs3)
790 rnCoreExpr (UfNote note expr)
791 = rnNote note `thenRn` \ (note', fvs1) ->
792 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
793 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
795 rnCoreExpr (UfLam bndr body)
796 = rnCoreBndr bndr $ \ bndr' ->
797 rnCoreExpr body `thenRn` \ (body', fvs) ->
798 returnRn (UfLam bndr' body', fvs)
800 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
801 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
802 rnCoreBndr bndr ( \ bndr' ->
803 rnCoreExpr body `thenRn` \ (body', fvs2) ->
804 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
805 ) `thenRn` \ (result, fvs3) ->
806 returnRn (result, fvs1 `plusFV` fvs3)
808 rnCoreExpr (UfLet (UfRec pairs) body)
809 = rnCoreBndrs bndrs $ \ bndrs' ->
810 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
811 rnCoreExpr body `thenRn` \ (body', fvs2) ->
812 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
814 (bndrs, rhss) = unzip pairs
818 rnCoreBndr (UfValBinder name ty) thing_inside
819 = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
820 bindCoreLocalFVRn name ( \ name' ->
821 thing_inside (UfValBinder name' ty')
822 ) `thenRn` \ (result, fvs2) ->
823 returnRn (result, fvs1 `plusFV` fvs2)
825 doc = text "unfolding id"
827 rnCoreBndr (UfTyBinder name kind) thing_inside
828 = bindCoreLocalFVRn name $ \ name' ->
829 thing_inside (UfTyBinder name' kind)
831 rnCoreBndrs [] thing_inside = thing_inside []
832 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
833 rnCoreBndrs bs $ \ names' ->
834 thing_inside (name':names')
838 rnCoreAlt (con, bndrs, rhs)
839 = rnUfCon con `thenRn` \ (con', fvs1) ->
840 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
841 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
842 returnRn ((con', bndrs', rhs'), fvs2)
843 ) `thenRn` \ (result, fvs3) ->
844 returnRn (result, fvs1 `plusFV` fvs3)
847 = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
848 returnRn (UfCoerce ty', fvs)
850 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
851 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
852 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
856 = returnRn (UfDefault, emptyFVs)
858 rnUfCon (UfDataAlt con)
859 = lookupOccRn con `thenRn` \ con' ->
860 returnRn (UfDataAlt con', unitFV con')
862 rnUfCon (UfLitAlt lit)
863 = returnRn (UfLitAlt lit, emptyFVs)
865 rnUfCon (UfLitLitAlt lit ty)
866 = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
867 returnRn (UfLitLitAlt lit ty', fvs)
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")]
971 badExtName :: ExtName -> Message
973 = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]