2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
7 module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
9 #include "HsVersions.h"
14 import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes )
15 import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
16 import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
17 extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
22 import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
23 import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
25 bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
26 bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
27 bindCoreLocalFVRn, bindCoreLocalsFVRn,
28 checkDupOrQualNames, checkDupNames,
29 mkImportedGlobalName, mkImportedGlobalFromRdrName,
30 newDFunName, getDFunKey, newImplicitBinder,
31 FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
35 import FunDeps ( oclose )
37 import Name ( Name, OccName,
38 ExportFlag(..), Provenance(..),
39 nameOccName, NamedThing(..)
42 import OccName ( mkDefaultMethodOcc )
43 import BasicTypes ( TopLevelFlag(..) )
44 import FiniteMap ( elemFM )
45 import PrelInfo ( derivableClassKeys,
46 deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
48 import Bag ( bagToList )
49 import List ( partition, nub )
51 import SrcLoc ( SrcLoc )
52 import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
53 import Unique ( Uniquable(..) )
54 import UniqFM ( lookupUFM )
55 import 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 rnHsType syn_doc 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 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
168 tname dname dwname snames src_loc))
169 = pushSrcLocRn src_loc $
171 lookupBndrRn cname `thenRn` \ cname' ->
173 -- Deal with the implicit tycon and datacon name
174 -- They aren't in scope (because they aren't visible to the user)
175 -- and what we want to do is simply look them up in the cache;
176 -- we jolly well ought to get a 'hit' there!
177 -- So the 'Imported' part of this call is not relevant.
178 -- Unclean; but since these two are the only place this happens
179 -- I can't work up the energy to do it more beautifully
180 mkImportedGlobalFromRdrName tname `thenRn` \ tname' ->
181 mkImportedGlobalFromRdrName dname `thenRn` \ dname' ->
182 mkImportedGlobalFromRdrName dwname `thenRn` \ dwname' ->
183 mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' ->
185 -- Tyvars scope over bindings and context
186 bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
188 -- Check the superclasses
189 rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
191 -- Check the functional dependencies
192 rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
194 -- Check the signatures
196 -- First process the class op sigs, then the fixity sigs.
197 (op_sigs, non_op_sigs) = partition isClassOpSig sigs
198 (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
200 checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
201 mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs
202 `thenRn` \ (sigs', sig_fvs) ->
203 mapRn_ (unknownSigErr) non_sigs `thenRn_`
205 binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
207 renameSigs False binders lookupOccRn fix_sigs
208 `thenRn` \ (fixs', fix_fvs) ->
211 checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
213 `thenRn` \ (mbinds', meth_fvs) ->
215 -- Typechecker is responsible for checking that we only
216 -- give default-method bindings for things in this class.
217 -- The renamer *could* check this for class decls, but can't
218 -- for instance decls.
220 ASSERT(isNoClassPragmas pragmas)
221 returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
222 NoClassPragmas tname' dname' dwname' snames' src_loc),
231 cls_doc = text "the declaration for class" <+> ppr cname
232 sig_doc = text "the signatures for class" <+> ppr cname
233 meth_doc = text "the default-methods for class" <+> ppr cname
235 sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
236 meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
237 meth_rdr_names = map fst meth_rdr_names_w_locs
239 rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
240 = pushSrcLocRn locn $
241 lookupBndrRn op `thenRn` \ op_name ->
243 -- Check the signature
244 rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
246 check_in_op_ty clas_tyvar =
247 checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
248 (classTyVarNotInOpTyErr clas_tyvar sig)
250 mapRn_ check_in_op_ty clas_tyvars `thenRn_`
252 -- Make the default-method name
253 getModeRn `thenRn` \ mode ->
255 SourceMode -> -- Source class decl
256 newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name ->
257 returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
260 -> -- Imported class that has a default method decl
261 -- See comments with tname, snames, above
262 lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name ->
263 returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
264 -- An imported class decl for a class decl that had an explicit default
265 -- method, mentions, rather than defines,
266 -- the default method, so we must arrange to pull it in
267 ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
269 returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
273 %*********************************************************
275 \subsection{Instance declarations}
277 %*********************************************************
280 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
281 = pushSrcLocRn src_loc $
282 rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
284 inst_tyvars = case inst_ty' of
285 HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
287 -- (Slightly strangely) the forall-d tyvars scope over
288 -- the method bindings too
291 -- Rename the bindings
292 -- NB meth_names can be qualified!
293 checkDupNames meth_doc meth_names `thenRn_`
294 extendTyVarEnvFVRn inst_tyvars (
296 ) `thenRn` \ (mbinds', meth_fvs) ->
298 binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
300 -- Delete sigs (&report) sigs that aren't allowed inside an
306 (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
308 okInInstDecl (FixSig _) = False
309 okInInstDecl (Sig _ _ _) = False
310 okInInstDecl _ = True
313 -- You can't have fixity decls & type signatures
314 -- within an instance declaration.
315 mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
317 -- Rename the prags and signatures.
318 -- Note that the type variables are not in scope here,
319 -- so that instance Eq a => Eq (T a) where
320 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
322 renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
324 getModeRn `thenRn` \ mode ->
326 InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name ->
327 returnRn (dfun_name, unitFV dfun_name)
328 SourceMode -> newDFunName (getDFunKey inst_ty') src_loc
329 `thenRn` \ dfun_name ->
330 returnRn (dfun_name, emptyFVs)
332 `thenRn` \ (dfun_name, dfun_fv) ->
334 -- The typechecker checks that all the bindings are for the right class.
335 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
336 inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
338 meth_doc = text "the bindings in an instance declaration"
339 meth_names = bagToList (collectMonoBinders mbinds)
342 %*********************************************************
344 \subsection{Default declarations}
346 %*********************************************************
349 rnDecl (DefD (DefaultDecl tys src_loc))
350 = pushSrcLocRn src_loc $
351 rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
352 returnRn (DefD (DefaultDecl tys' src_loc), fvs)
354 doc_str = text "a `default' declaration"
357 %*********************************************************
359 \subsection{Foreign declarations}
361 %*********************************************************
364 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
365 = pushSrcLocRn src_loc $
366 lookupOccRn name `thenRn` \ name' ->
368 ok_ext_nm Dynamic = True
369 ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
370 ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
372 fvs1 = case imp_exp of
373 FoImport _ | not isDyn -> emptyFVs
375 FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
378 | otherwise -> mkNameSet [name']
381 checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
382 rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
383 returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
386 fo_decl_msg = ptext SLIT("a foreign declaration")
387 isDyn = isDynamicExtName ext_nm
390 %*********************************************************
394 %*********************************************************
397 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
398 = pushSrcLocRn src_loc $
399 lookupOccRn var `thenRn` \ var' ->
400 rnRuleBody body `thenRn` \ (body', fvs) ->
401 returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
403 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
405 pushSrcLocRn src_loc $
407 bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
408 bindLocalsFVRn doc (map get_var vars) $ \ ids ->
409 mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
411 rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
412 rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
413 checkRn (validRuleLhs ids lhs')
414 (badRuleLhsErr rule_name lhs') `thenRn_`
416 bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
418 mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
419 returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
420 fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
422 doc = text "the transformation rule" <+> ptext rule_name
423 sig_tvs = extractRuleBndrsTyVars vars
425 get_var (RuleBndr v) = v
426 get_var (RuleBndrSig v _) = v
428 rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
429 rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
430 returnRn (RuleBndrSig id t', fvs)
434 %*********************************************************
436 \subsection{Support code for type/data declarations}
438 %*********************************************************
441 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
443 rnDerivs Nothing -- derivs not specified
444 = returnRn (Nothing, emptyFVs)
447 = mapRn do_one clss `thenRn` \ clss' ->
448 returnRn (Just clss', mkNameSet clss')
450 do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
451 checkRn (getUnique clas_name `elem` derivableClassKeys)
452 (derivingNonStdClassErr clas_name) `thenRn_`
457 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
458 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
460 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
461 rnConDecl (ConDecl name wkr tvs cxt details locn)
462 = pushSrcLocRn locn $
463 checkConName name `thenRn_`
464 lookupBndrRn name `thenRn` \ new_name ->
466 mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr ->
467 -- See comments with ClassDecl
469 bindTyVarsFVRn doc tvs $ \ new_tyvars ->
470 rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
471 rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
472 returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
473 cxt_fvs `plusFV` det_fvs)
475 doc = text "the definition of data constructor" <+> quotes (ppr name)
477 rnConDetails doc locn (VanillaCon tys)
478 = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) ->
479 returnRn (VanillaCon new_tys, fvs)
481 rnConDetails doc locn (InfixCon ty1 ty2)
482 = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
483 rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
484 returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
486 rnConDetails doc locn (NewCon ty mb_field)
487 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
488 rn_field mb_field `thenRn` \ new_mb_field ->
489 returnRn (NewCon new_ty new_mb_field, fvs)
491 rn_field Nothing = returnRn Nothing
493 lookupBndrRn f `thenRn` \ new_f ->
494 returnRn (Just new_f)
496 rnConDetails doc locn (RecCon fields)
497 = checkDupOrQualNames doc field_names `thenRn_`
498 mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
499 returnRn (RecCon new_fields, fvs)
501 field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
503 rnField doc (names, ty)
504 = mapRn lookupBndrRn names `thenRn` \ new_names ->
505 rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
506 returnRn ((new_names, new_ty), fvs)
508 rnBangTy doc (Banged ty)
509 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
510 returnRn (Banged new_ty, fvs)
512 rnBangTy doc (Unbanged ty)
513 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
514 returnRn (Unbanged new_ty, fvs)
516 rnBangTy doc (Unpacked ty)
517 = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
518 returnRn (Unpacked new_ty, fvs)
520 -- This data decl will parse OK
522 -- treating "a" as the constructor.
523 -- It is really hard to make the parser spot this malformation.
524 -- So the renamer has to check that the constructor is legal
526 -- We can get an operator as the constructor, even in the prefix form:
527 -- data T = :% Int Int
528 -- from interface files, which always print in prefix form
531 = checkRn (isRdrDataCon name)
536 %*********************************************************
538 \subsection{Support code to rename types}
540 %*********************************************************
543 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
544 -- rnHsSigType is used for source-language type signatures,
545 -- which use *implicit* universal quantification.
546 rnHsSigType doc_str ty
547 = rnHsPolyType (text "the type signature for" <+> doc_str) ty
549 ---------------------------------------
550 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
551 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
552 -- The former is called for the top level of type sigs and function args.
554 ---------------------------------------
555 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
556 -- From source code (no kinds on tyvars)
557 -- Given the signature C => T we universally quantify
558 -- over FV(T) \ {in-scope-tyvars}
559 = getLocalNameEnv `thenRn` \ name_env ->
561 mentioned_in_tau = extractHsTyRdrTyVars ty
562 forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
564 checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
565 rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
567 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
568 -- Explicit quantification.
569 -- Check that the forall'd tyvars are a subset of the
570 -- free tyvars in the tau-type part
571 -- That's only a warning... unless the tyvar is constrained by a
572 -- context in which case it's an error
574 mentioned_in_tau = extractHsTyRdrTyVars tau
575 mentioned_in_ctxt = nub [tv | p <- ctxt,
577 tv <- extractHsTyRdrTyVars ty]
578 tys_of_pred (HsPClass clas tys) = tys
579 tys_of_pred (HsPIParam n ty) = [ty]
581 dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
582 -- dubious = explicitly quantified but not mentioned in tau type
584 (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
585 -- bad = explicitly quantified and constrained, but not mentioned in tau
586 -- warn = explicitly quantified but not mentioned in ctxt or tau
588 forall_tyvar_names = map getTyVarName forall_tyvars
590 -- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
591 mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
592 checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
593 rnForAll doc forall_tyvars ctxt' tau
595 rnHsPolyType doc other_ty = rnHsType doc other_ty
598 -- Check that each constraint mentions at least one of the forall'd type variables
599 -- Since the forall'd type variables are a subset of the free tyvars
600 -- of the tau-type part, this guarantees that every constraint mentions
601 -- at least one of the free tyvars in ty
602 checkConstraints doc forall_tyvars tau_vars ctxt ty
603 = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
604 returnRn (catMaybes maybe_ctxt')
605 -- Remove problem ones, to avoid duplicate error message.
607 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
608 | not_univ = failWithRn Nothing (univErr doc p ty)
609 | otherwise = returnRn (Just p)
611 ct_vars = extractHsTysRdrTyVars tys
612 not_univ = -- At least one of the tyvars in each constraint must
613 -- be universally quantified. This restriction isn't in Hugs
614 not (any (`elem` forall_tyvars) ct_vars)
615 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
618 rnForAll doc forall_tyvars ctxt ty
619 = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
620 rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
621 rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
622 returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
623 cxt_fvs `plusFV` ty_fvs)
625 ---------------------------------------
626 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
627 = addWarnRn (unexpectedForAllTy ty) `thenRn_`
630 rnHsType doc (MonoTyVar tyvar)
631 = lookupOccRn tyvar `thenRn` \ tyvar' ->
632 returnRn (MonoTyVar tyvar', unitFV tyvar')
634 rnHsType doc (MonoFunTy ty1 ty2)
635 = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
636 -- Might find a for-all as the arg of a function type
637 rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
638 -- Or as the result. This happens when reading Prelude.hi
639 -- when we find return :: forall m. Monad m -> forall a. a -> m a
640 returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
642 rnHsType doc (MonoListTy ty)
643 = rnHsType doc ty `thenRn` \ (ty', fvs) ->
644 returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
646 -- Unboxed tuples are allowed to have poly-typed arguments. These
647 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
648 rnHsType doc (MonoTupleTy tys boxed)
650 then mapFvRn (rnHsType doc) tys
651 else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) ->
652 returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
654 tup_con_name = tupleTyCon_name boxed (length tys)
656 rnHsType doc (MonoTyApp ty1 ty2)
657 = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
658 rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
659 returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
661 rnHsType doc (MonoIParamTy n ty)
662 = getIPName n `thenRn` \ name ->
663 rnHsType doc ty `thenRn` \ (ty', fvs) ->
664 returnRn (MonoIParamTy name ty', fvs)
666 rnHsType doc (MonoDictTy clas tys)
667 = lookupOccRn clas `thenRn` \ clas' ->
668 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
669 returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
671 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
672 = bindUVarRn doc uv_rdr $ \ uv_name ->
673 rnHsType doc ty `thenRn` \ (ty', fvs) ->
674 returnRn (MonoUsgForAllTy uv_name ty',
677 rnHsType doc (MonoUsgTy usg ty)
678 = newUsg usg `thenRn` \ (usg', usg_fvs) ->
679 rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) ->
680 -- A for-all can occur inside a usage annotation
681 returnRn (MonoUsgTy usg' ty',
682 usg_fvs `plusFV` ty_fvs)
684 newUsg usg = case usg of
685 MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
686 MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
687 MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
688 returnRn (MonoUsVar uv_name, emptyFVs)
690 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
695 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
698 = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
700 (_, dup_asserts) = removeDups (cmpHsPred compare) theta
702 -- Check for duplicate assertions
703 -- If this isn't an error, then it ought to be:
704 mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
706 returnRn (theta, plusFVs fvs_s)
708 rnPred doc (HsPClass clas tys)
709 = lookupOccRn clas `thenRn` \ clas_name ->
710 rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
711 returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
712 rnPred doc (HsPIParam n ty)
713 = getIPName n `thenRn` \ name ->
714 rnHsType doc ty `thenRn` \ (ty', fvs) ->
715 returnRn (HsPIParam name ty', fvs)
719 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
722 = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
723 returnRn (theta, plusFVs fvs_s)
726 = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
727 rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
728 returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
730 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
732 = lookupOccRn tyvar `thenRn` \ tyvar' ->
733 returnRn (tyvar', unitFV tyvar')
736 %*********************************************************
740 %*********************************************************
743 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
745 rnIdInfo (HsWorker worker)
746 = lookupOccRn worker `thenRn` \ worker' ->
747 returnRn (HsWorker worker', unitFV worker')
749 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
750 returnRn (HsUnfold inline expr', fvs)
751 rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
752 rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
753 rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
754 rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
755 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
756 `thenRn` \ (rule_body', fvs) ->
757 returnRn (HsSpecialise rule_body', fvs)
759 rnRuleBody (UfRuleBody str vars args rhs)
760 = rnCoreBndrs vars $ \ vars' ->
761 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
762 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
763 returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
766 @UfCore@ expressions.
769 rnCoreExpr (UfType ty)
770 = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
771 returnRn (UfType ty', fvs)
774 = lookupOccRn v `thenRn` \ v' ->
775 returnRn (UfVar v', unitFV v')
778 = returnRn (UfLit l, emptyFVs)
780 rnCoreExpr (UfLitLit l ty)
781 = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
782 returnRn (UfLitLit l ty', fvs)
784 rnCoreExpr (UfCCall cc ty)
785 = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) ->
786 returnRn (UfCCall cc ty', fvs)
788 rnCoreExpr (UfTuple con args)
789 = lookupOccRn con `thenRn` \ con' ->
790 mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) ->
791 returnRn (UfTuple con' args', fvs `addOneFV` con')
793 rnCoreExpr (UfApp fun arg)
794 = rnCoreExpr fun `thenRn` \ (fun', fv1) ->
795 rnCoreExpr arg `thenRn` \ (arg', fv2) ->
796 returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
798 rnCoreExpr (UfCase scrut bndr alts)
799 = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) ->
800 bindCoreLocalFVRn bndr ( \ bndr' ->
801 mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) ->
802 returnRn (UfCase scrut' bndr' alts', fvs2)
803 ) `thenRn` \ (case', fvs3) ->
804 returnRn (case', fvs1 `plusFV` fvs3)
806 rnCoreExpr (UfNote note expr)
807 = rnNote note `thenRn` \ (note', fvs1) ->
808 rnCoreExpr expr `thenRn` \ (expr', fvs2) ->
809 returnRn (UfNote note' expr', fvs1 `plusFV` fvs2)
811 rnCoreExpr (UfLam bndr body)
812 = rnCoreBndr bndr $ \ bndr' ->
813 rnCoreExpr body `thenRn` \ (body', fvs) ->
814 returnRn (UfLam bndr' body', fvs)
816 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
817 = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) ->
818 rnCoreBndr bndr ( \ bndr' ->
819 rnCoreExpr body `thenRn` \ (body', fvs2) ->
820 returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
821 ) `thenRn` \ (result, fvs3) ->
822 returnRn (result, fvs1 `plusFV` fvs3)
824 rnCoreExpr (UfLet (UfRec pairs) body)
825 = rnCoreBndrs bndrs $ \ bndrs' ->
826 mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) ->
827 rnCoreExpr body `thenRn` \ (body', fvs2) ->
828 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
830 (bndrs, rhss) = unzip pairs
834 rnCoreBndr (UfValBinder name ty) thing_inside
835 = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
836 bindCoreLocalFVRn name ( \ name' ->
837 thing_inside (UfValBinder name' ty')
838 ) `thenRn` \ (result, fvs2) ->
839 returnRn (result, fvs1 `plusFV` fvs2)
841 doc = text "unfolding id"
843 rnCoreBndr (UfTyBinder name kind) thing_inside
844 = bindCoreLocalFVRn name $ \ name' ->
845 thing_inside (UfTyBinder name' kind)
847 rnCoreBndrs [] thing_inside = thing_inside []
848 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
849 rnCoreBndrs bs $ \ names' ->
850 thing_inside (name':names')
854 rnCoreAlt (con, bndrs, rhs)
855 = rnUfCon con `thenRn` \ (con', fvs1) ->
856 bindCoreLocalsFVRn bndrs ( \ bndrs' ->
857 rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
858 returnRn ((con', bndrs', rhs'), fvs2)
859 ) `thenRn` \ (result, fvs3) ->
860 returnRn (result, fvs1 `plusFV` fvs3)
863 = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
864 returnRn (UfCoerce ty', fvs)
866 rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
867 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
868 rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
872 = returnRn (UfDefault, emptyFVs)
874 rnUfCon (UfDataAlt con)
875 = lookupOccRn con `thenRn` \ con' ->
876 returnRn (UfDataAlt con', unitFV con')
878 rnUfCon (UfLitAlt lit)
879 = returnRn (UfLitAlt lit, emptyFVs)
881 rnUfCon (UfLitLitAlt lit ty)
882 = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
883 returnRn (UfLitLitAlt lit ty', fvs)
886 %*********************************************************
888 \subsection{Rule shapes}
890 %*********************************************************
892 Check the shape of a transformation rule LHS. Currently
893 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
894 not one of the @forall@'d variables.
897 validRuleLhs foralls lhs
900 check (HsApp e1 e2) = check e1
901 check (HsVar v) | v `notElem` foralls = True
906 %*********************************************************
910 %*********************************************************
913 derivingNonStdClassErr clas
914 = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
916 classTyVarNotInOpTyErr clas_tyvar sig
917 = hang (hsep [ptext SLIT("Class type variable"),
918 quotes (ppr clas_tyvar),
919 ptext SLIT("does not appear in method signature")])
922 dupClassAssertWarn ctxt (assertion : dups)
923 = sep [hsep [ptext SLIT("Duplicate class assertion"),
924 quotes (pprHsPred assertion),
925 ptext SLIT("in the context:")],
926 nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
929 = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
931 forAllWarn doc ty tyvar
932 | not opt_WarnUnusedMatches = returnRn ()
934 = getModeRn `thenRn` \ mode ->
937 InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
938 -- unless DEBUG is on, in which case it is slightly
939 -- informative. They can arise from mkRhsTyLam,
940 #endif -- leading to (say) f :: forall a b. [b] -> [b]
944 sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
945 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
947 (ptext SLIT("In") <+> doc))
950 forAllErr doc ty tyvar
952 sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
953 nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
955 (ptext SLIT("In") <+> doc))
957 univErr doc constraint ty
958 = sep [ptext SLIT("All of the type variable(s) in the constraint")
959 <+> quotes (pprHsPred constraint)
960 <+> ptext SLIT("are already in scope"),
961 nest 4 (ptext SLIT("At least one must be universally quantified here"))
964 (ptext SLIT("In") <+> doc)
966 ambigErr doc constraint ty
967 = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
968 nest 4 (ptext SLIT("in the type:") <+> ppr ty),
969 nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
971 (ptext SLIT("In") <+> doc)
973 unexpectedForAllTy ty
974 = ptext SLIT("Unexpected forall type:") <+> ppr ty
976 badRuleLhsErr name lhs
977 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
978 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
980 ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
983 = sep [ptext SLIT("Rule") <+> ptext name <> colon,
984 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
985 ptext SLIT("does not appear on left hand side")]
987 badExtName :: ExtName -> Message
989 = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]