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 `thenRn` \ (sigs', sig_fvs) ->
207 mapRn_ (unknownSigErr) non_sigs `thenRn_`
209 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
211 renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) ->
214 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
216 `thenRn` \ (mbinds', meth_fvs) ->
218 -- Typechecker is responsible for checking that we only
219 -- give default-method bindings for things in this class.
220 -- The renamer *could* check this for class decls, but can't
221 -- for instance decls.
223 ASSERT(isNoClassPragmas pragmas)
224 returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
225 NoClassPragmas tname' dname' dwname' snames' src_loc),
234 cls_doc = text "the declaration for class" <+> ppr cname
235 sig_doc = text "the signatures for class" <+> ppr cname
236 meth_doc = text "the default-methods for class" <+> ppr cname
238 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
239 meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
240 meth_rdr_names = map fst meth_rdr_names_w_locs
242 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
243 = pushSrcLocRn locn $
244 lookupBndrRn op `thenRn` \ op_name ->
246 -- Check the signature
247 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
249 check_in_op_ty clas_tyvar =
250 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
251 (classTyVarNotInOpTyErr clas_tyvar sig)
253 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
255 -- Make the default-method name
256 getModeRn `thenRn` \ mode ->
258 SourceMode -> -- Source class decl
259 newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name ->
260 returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
263 -> -- Imported class that has a default method decl
264 -- See comments with tname, snames, above
265 lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name ->
266 returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
267 -- An imported class decl for a class decl that had an explicit default
268 -- method, mentions, rather than defines,
269 -- the default method, so we must arrange to pull it in
270 ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
272 returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
276 %*********************************************************
278 \subsection{Instance declarations}
280 %*********************************************************
283 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
284 = pushSrcLocRn src_loc $
285 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
287 inst_tyvars = case inst_ty' of
288 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
290 -- (Slightly strangely) the forall-d tyvars scope over
291 -- the method bindings too
294 -- Rename the bindings
295 -- NB meth_names can be qualified!
296 checkDupNames meth_doc meth_names `thenRn_`
297 extendTyVarEnvFVRn inst_tyvars (
299 ) `thenRn` \ (mbinds', meth_fvs) ->
301 binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
303 -- Delete sigs (&report) sigs that aren't allowed inside an
309 (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
311 okInInstDecl (FixSig _) = False
312 okInInstDecl (Sig _ _ _) = False
313 okInInstDecl _ = True
316 -- You can't have fixity decls & type signatures
317 -- within an instance declaration.
318 mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
320 -- Rename the prags and signatures.
321 -- Note that the type variables are not in scope here,
322 -- so that instance Eq a => Eq (T a) where
323 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
325 renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
327 getModeRn `thenRn` \ mode ->
329 InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name ->
330 returnRn (dfun_name, unitFV dfun_name)
331 SourceMode -> newDFunName (getDFunKey inst_ty') src_loc
332 `thenRn` \ dfun_name ->
333 returnRn (dfun_name, emptyFVs)
335 `thenRn` \ (dfun_name, dfun_fv) ->
337 -- The typechecker checks that all the bindings are for the right class.
338 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
339 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
341 meth_doc = text "the bindings in an instance declaration"
342 meth_names = bagToList (collectMonoBinders mbinds)
345 %*********************************************************
347 \subsection{Default declarations}
349 %*********************************************************
352 rnDecl (DefD (DefaultDecl tys src_loc))
353 = pushSrcLocRn src_loc $
354 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
355 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
357 doc_str = text "a `default' declaration"
360 %*********************************************************
362 \subsection{Foreign declarations}
364 %*********************************************************
367 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
368 = pushSrcLocRn src_loc $
369 lookupOccRn name `thenRn` \ name' ->
371 ok_ext_nm Dynamic = True
372 ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
373 ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
375 fvs1 = case imp_exp of
376 FoImport _ | not isDyn -> emptyFVs
378 FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
381 | otherwise -> mkNameSet [name']
384 checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
385 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
386 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
389 fo_decl_msg = ptext SLIT("a foreign declaration")
390 isDyn = isDynamicExtName ext_nm
393 %*********************************************************
397 %*********************************************************
400 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
401 = pushSrcLocRn src_loc $
402 lookupOccRn var `thenRn` \ var' ->
403 rnRuleBody body `thenRn` \ (body', fvs) ->
404 returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
406 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
408 pushSrcLocRn src_loc $
410 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
411 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
412 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
414 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
415 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
416 checkRn (validRuleLhs ids lhs')
417 (badRuleLhsErr rule_name lhs') `thenRn_`
419 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
421 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
422 returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
423 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
425 doc = text "the transformation rule" <+> ptext rule_name
426 sig_tvs = extractRuleBndrsTyVars vars
428 get_var (RuleBndr v) = v
429 get_var (RuleBndrSig v _) = v
431 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
432 rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
433 returnRn (RuleBndrSig id t', fvs)
437 %*********************************************************
439 \subsection{Support code for type/data declarations}
441 %*********************************************************
444 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
446 rnDerivs Nothing -- derivs not specified
447 = returnRn (Nothing, emptyFVs)
450 = mapRn do_one clss `thenRn` \ clss' ->
451 returnRn (Just clss', mkNameSet clss')
453 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
454 checkRn (getUnique clas_name `elem` derivableClassKeys)
455 (derivingNonStdClassErr clas_name) `thenRn_`
460 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
461 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
463 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
464 rnConDecl (ConDecl name wkr tvs cxt details locn)
465 = pushSrcLocRn locn $
466 checkConName name `thenRn_`
467 lookupBndrRn name `thenRn` \ new_name ->
469 mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr ->
470 -- See comments with ClassDecl
472 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
473 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
474 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
475 returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
476 cxt_fvs `plusFV` det_fvs)
478 doc = text "the definition of data constructor" <+> quotes (ppr name)
480 rnConDetails doc locn (VanillaCon tys)
481 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
482 returnRn (VanillaCon new_tys, fvs)
484 rnConDetails doc locn (InfixCon ty1 ty2)
485 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
486 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
487 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
489 rnConDetails doc locn (NewCon ty mb_field)
490 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
491 rn_field mb_field `thenRn` \ new_mb_field ->
492 returnRn (NewCon new_ty new_mb_field, fvs)
494 rn_field Nothing = returnRn Nothing
496 lookupBndrRn f `thenRn` \ new_f ->
497 returnRn (Just new_f)
499 rnConDetails doc locn (RecCon fields)
500 = checkDupOrQualNames doc field_names `thenRn_`
501 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
502 returnRn (RecCon new_fields, fvs)
504 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
506 rnField doc (names, ty)
507 = mapRn lookupBndrRn names `thenRn` \ new_names ->
508 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
509 returnRn ((new_names, new_ty), fvs)
511 rnBangTy doc (Banged ty)
512 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
513 returnRn (Banged new_ty, fvs)
515 rnBangTy doc (Unbanged ty)
516 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
517 returnRn (Unbanged new_ty, fvs)
519 rnBangTy doc (Unpacked ty)
520 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
521 returnRn (Unpacked new_ty, fvs)
523 -- This data decl will parse OK
525 -- treating "a" as the constructor.
526 -- It is really hard to make the parser spot this malformation.
527 -- So the renamer has to check that the constructor is legal
529 -- We can get an operator as the constructor, even in the prefix form:
530 -- data T = :% Int Int
531 -- from interface files, which always print in prefix form
534 = checkRn (isRdrDataCon name)
539 %*********************************************************
541 \subsection{Support code to rename types}
543 %*********************************************************
546 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
547 -- rnHsSigType is used for source-language type signatures,
548 -- which use *implicit* universal quantification.
549 rnHsSigType doc_str ty
550 = rnHsPolyType (text "the type signature for" <+> doc_str) ty
552 ---------------------------------------
553 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
554 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
555 -- The former is called for the top level of type sigs and function args.
557 ---------------------------------------
558 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
559 -- Implicit quantifiction in source code (no kinds on tyvars)
560 -- Given the signature C => T we universally quantify
561 -- over FV(T) \ {in-scope-tyvars}
562 = getLocalNameEnv `thenRn` \ name_env ->
564 mentioned_in_tau = extractHsTyRdrTyVars ty
565 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
567 checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
568 rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
570 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
571 -- Explicit quantification.
572 -- Check that the forall'd tyvars are a subset of the
573 -- free tyvars in the tau-type part
574 -- That's only a warning... unless the tyvar is constrained by a
575 -- context in which case it's an error
577 mentioned_in_tau = extractHsTyRdrTyVars tau
578 mentioned_in_ctxt = nub [tv | p <- ctxt,
580 tv <- extractHsTyRdrTyVars ty]
581 tys_of_pred (HsPClass clas tys) = tys
582 tys_of_pred (HsPIParam n ty) = [ty]
584 dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
585 -- dubious = explicitly quantified but not mentioned in tau type
587 (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
588 -- bad = explicitly quantified and constrained, but not mentioned in tau
589 -- warn = explicitly quantified but not mentioned in ctxt or tau
591 forall_tyvar_names = map getTyVarName forall_tyvars
593 -- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
594 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
595 checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
596 rnForAll doc forall_tyvars ctxt' tau
598 rnHsPolyType doc other_ty = rnHsType doc other_ty
601 -- Check that each constraint mentions at least one of the forall'd type variables
602 -- Since the forall'd type variables are a subset of the free tyvars
603 -- of the tau-type part, this guarantees that every constraint mentions
604 -- at least one of the free tyvars in ty
605 checkConstraints doc forall_tyvars tau_vars ctxt ty
606 = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
607 returnRn (catMaybes maybe_ctxt')
608 -- Remove problem ones, to avoid duplicate error message.
610 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
611 | not_univ = failWithRn Nothing (univErr doc p ty)
612 | otherwise = returnRn (Just p)
614 ct_vars = extractHsTysRdrTyVars tys
615 not_univ = -- At least one of the tyvars in each constraint must
616 -- be universally quantified. This restriction isn't in Hugs
617 not (any (`elem` forall_tyvars) ct_vars)
618 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
621 rnForAll doc forall_tyvars ctxt ty
622 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
623 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
624 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
625 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
626 cxt_fvs `plusFV` ty_fvs)
628 ---------------------------------------
629 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
630 = addWarnRn (unexpectedForAllTy ty) `thenRn_`
633 rnHsType doc (MonoTyVar tyvar)
634 = lookupOccRn tyvar `thenRn` \ tyvar' ->
635 returnRn (MonoTyVar tyvar', unitFV tyvar')
637 rnHsType doc (MonoFunTy ty1 ty2)
638 = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
639 -- Might find a for-all as the arg of a function type
640 rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
641 -- Or as the result. This happens when reading Prelude.hi
642 -- when we find return :: forall m. Monad m -> forall a. a -> m a
643 returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
645 rnHsType doc (MonoListTy ty)
646 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
647 returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
649 -- Unboxed tuples are allowed to have poly-typed arguments. These
650 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
651 rnHsType doc (MonoTupleTy tys boxed)
653 then mapFvRn (rnHsType doc) tys
654 else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) ->
655 returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
657 tup_con_name = tupleTyCon_name boxed (length tys)
659 rnHsType doc (MonoTyApp ty1 ty2)
660 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
661 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
662 returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
664 rnHsType doc (MonoIParamTy n ty)
665 = getIPName n `thenRn` \ name ->
666 rnHsType doc ty `thenRn` \ (ty', fvs) ->
667 returnRn (MonoIParamTy name ty', fvs)
669 rnHsType doc (MonoDictTy clas tys)
670 = lookupOccRn clas `thenRn` \ clas' ->
671 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
672 returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
674 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
675 = bindUVarRn doc uv_rdr $ \ uv_name ->
676 rnHsType doc ty `thenRn` \ (ty', fvs) ->
677 returnRn (MonoUsgForAllTy uv_name ty',
680 rnHsType doc (MonoUsgTy usg ty)
681 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
682 rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) ->
683 -- A for-all can occur inside a usage annotation
684 returnRn (MonoUsgTy usg' ty',
685 usg_fvs `plusFV` ty_fvs)
687 newUsg usg = case usg of
688 MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
689 MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
690 MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
691 returnRn (MonoUsVar uv_name, emptyFVs)
693 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
698 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
701 = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
703 (_, dup_asserts) = removeDups (cmpHsPred compare) theta
705 -- Check for duplicate assertions
706 -- If this isn't an error, then it ought to be:
707 mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
709 returnRn (theta, plusFVs fvs_s)
711 rnPred doc (HsPClass clas tys)
712 = lookupOccRn clas `thenRn` \ clas_name ->
713 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
714 returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
715 rnPred doc (HsPIParam n ty)
716 = getIPName n `thenRn` \ name ->
717 rnHsType doc ty `thenRn` \ (ty', fvs) ->
718 returnRn (HsPIParam name ty', fvs)
722 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
725 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
726 returnRn (theta, plusFVs fvs_s)
729 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
730 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
731 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
733 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
735 = lookupOccRn tyvar `thenRn` \ tyvar' ->
736 returnRn (tyvar', unitFV tyvar')
739 %*********************************************************
743 %*********************************************************
746 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
748 rnIdInfo (HsWorker worker)
749 = lookupOccRn worker `thenRn` \ worker' ->
750 returnRn (HsWorker worker', unitFV worker')
752 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
753 returnRn (HsUnfold inline expr', fvs)
754 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
755 rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
756 rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
757 rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
758 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
759 `thenRn` \ (rule_body', fvs) ->
760 returnRn (HsSpecialise rule_body', fvs)
762 rnRuleBody (UfRuleBody str vars args rhs)
763 = rnCoreBndrs vars $ \ vars' ->
764 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
765 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
766 returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
769 @UfCore@ expressions.
772 rnCoreExpr (UfType ty)
773 = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
774 returnRn (UfType ty', fvs)
777 = lookupOccRn v `thenRn` \ v' ->
778 returnRn (UfVar v', unitFV v')
781 = returnRn (UfLit l, emptyFVs)
783 rnCoreExpr (UfLitLit l ty)
784 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
785 returnRn (UfLitLit l ty', fvs)
787 rnCoreExpr (UfCCall cc ty)
788 = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) ->
789 returnRn (UfCCall cc ty', fvs)
791 rnCoreExpr (UfTuple con args)
792 = lookupOccRn con `thenRn` \ con' ->
793 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) ->
794 returnRn (UfTuple con' args', fvs `addOneFV` con')
796 rnCoreExpr (UfApp fun arg)
797 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
798 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
799 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
801 rnCoreExpr (UfCase scrut bndr alts)
802 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
803 bindCoreLocalFVRn bndr ( \ bndr' ->
804 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
805 returnRn (UfCase scrut' bndr' alts', fvs2)
806 ) `thenRn` \ (case', fvs3) ->
807 returnRn (case', fvs1 `plusFV` fvs3)
809 rnCoreExpr (UfNote note expr)
810 = rnNote note `thenRn` \ (note', fvs1) ->
811 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
812 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
814 rnCoreExpr (UfLam bndr body)
815 = rnCoreBndr bndr $ \ bndr' ->
816 rnCoreExpr body `thenRn` \ (body', fvs) ->
817 returnRn (UfLam bndr' body', fvs)
819 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
820 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
821 rnCoreBndr bndr ( \ bndr' ->
822 rnCoreExpr body `thenRn` \ (body', fvs2) ->
823 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
824 ) `thenRn` \ (result, fvs3) ->
825 returnRn (result, fvs1 `plusFV` fvs3)
827 rnCoreExpr (UfLet (UfRec pairs) body)
828 = rnCoreBndrs bndrs $ \ bndrs' ->
829 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
830 rnCoreExpr body `thenRn` \ (body', fvs2) ->
831 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
833 (bndrs, rhss) = unzip pairs
837 rnCoreBndr (UfValBinder name ty) thing_inside
838 = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
839 bindCoreLocalFVRn name ( \ name' ->
840 thing_inside (UfValBinder name' ty')
841 ) `thenRn` \ (result, fvs2) ->
842 returnRn (result, fvs1 `plusFV` fvs2)
844 doc = text "unfolding id"
846 rnCoreBndr (UfTyBinder name kind) thing_inside
847 = bindCoreLocalFVRn name $ \ name' ->
848 thing_inside (UfTyBinder name' kind)
850 rnCoreBndrs [] thing_inside = thing_inside []
851 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
852 rnCoreBndrs bs $ \ names' ->
853 thing_inside (name':names')
857 rnCoreAlt (con, bndrs, rhs)
858 = rnUfCon con `thenRn` \ (con', fvs1) ->
859 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
860 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
861 returnRn ((con', bndrs', rhs'), fvs2)
862 ) `thenRn` \ (result, fvs3) ->
863 returnRn (result, fvs1 `plusFV` fvs3)
866 = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
867 returnRn (UfCoerce ty', fvs)
869 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
870 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
871 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
875 = returnRn (UfDefault, emptyFVs)
877 rnUfCon (UfDataAlt con)
878 = lookupOccRn con `thenRn` \ con' ->
879 returnRn (UfDataAlt con', unitFV con')
881 rnUfCon (UfLitAlt lit)
882 = returnRn (UfLitAlt lit, emptyFVs)
884 rnUfCon (UfLitLitAlt lit ty)
885 = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
886 returnRn (UfLitLitAlt lit ty', fvs)
889 %*********************************************************
891 \subsection{Rule shapes}
893 %*********************************************************
895 Check the shape of a transformation rule LHS. Currently
896 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
897 not one of the @forall@'d variables.
900 validRuleLhs foralls lhs
903 check (HsApp e1 e2) = check e1
904 check (HsVar v) | v `notElem` foralls = True
909 %*********************************************************
913 %*********************************************************
916 derivingNonStdClassErr clas
917 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
919 classTyVarNotInOpTyErr clas_tyvar sig
920 = hang (hsep [ptext SLIT("Class type variable"),
921 quotes (ppr clas_tyvar),
922 ptext SLIT("does not appear in method signature")])
925 dupClassAssertWarn ctxt (assertion : dups)
926 = sep [hsep [ptext SLIT("Duplicate class assertion"),
927 quotes (pprHsPred assertion),
928 ptext SLIT("in the context:")],
929 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
932 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
934 forAllWarn doc ty tyvar
935 | not opt_WarnUnusedMatches = returnRn ()
937 = getModeRn `thenRn` \ mode ->
940 InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
941 -- unless DEBUG is on, in which case it is slightly
942 -- informative. They can arise from mkRhsTyLam,
943 #endif -- leading to (say) f :: forall a b. [b] -> [b]
947 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
948 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
950 (ptext SLIT("In") <+> doc))
953 forAllErr doc ty tyvar
955 sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
956 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
958 (ptext SLIT("In") <+> doc))
960 univErr doc constraint ty
961 = sep [ptext SLIT("All of the type variable(s) in the constraint")
962 <+> quotes (pprHsPred constraint)
963 <+> ptext SLIT("are already in scope"),
964 nest 4 (ptext SLIT("At least one must be universally quantified here"))
967 (ptext SLIT("In") <+> doc)
969 ambigErr doc constraint ty
970 = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
971 nest 4 (ptext SLIT("in the type:") <+> ppr ty),
972 nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
974 (ptext SLIT("In") <+> doc)
976 unexpectedForAllTy ty
977 = ptext SLIT("Unexpected forall type:") <+> ppr ty
979 badRuleLhsErr name lhs
980 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
981 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
983 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
986 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
987 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
988 ptext SLIT("does not appear on left hand side")]
990 badExtName :: ExtName -> Message
992 = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]