2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnSource]{Main pass of renamer}
7 #include "HsVersions.h"
9 module RnSource ( rnDecl, rnHsType ) where
12 IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
15 import HsDecls ( HsIdInfo(..) )
17 import HsTypes ( getTyVarName )
21 import CmdLineOpts ( opt_IgnoreIfacePragmas )
23 import RnBinds ( rnTopBinds, rnMethodBinds )
24 import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
25 lookupOptionalOccRn, newSysName, newDfunName,
26 listType_RDR, tupleType_RDR )
29 import Name ( Name, isLocallyDefined,
30 OccName(..), occNameString, prefixOccName,
33 SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
36 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
37 import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
38 import Id ( GenId{-instance NamedThing-} )
39 import IdInfo ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
40 import SpecEnv ( SpecEnv )
41 import Lex ( isLexCon )
42 import CoreUnfold ( Unfolding(..), SimpleUnfolding )
43 import MagicUFs ( MagicUnfoldingFun )
44 import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR )
45 import ListSetOps ( unionLists, minusList )
46 import Maybes ( maybeToBool, catMaybes )
47 import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
48 import Outputable ( Outputable(..){-instances-} )
49 --import PprStyle -- ToDo:rm
51 import SrcLoc ( SrcLoc )
52 -- import TyCon ( TyCon{-instance NamedThing-} )
53 import Unique ( Unique )
54 import UniqSet ( SYN_IE(UniqSet) )
55 import UniqFM ( UniqFM, lookupUFM )
56 import Util ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
57 panic, assertPanic{- , pprTrace ToDo:rm-} )
60 rnDecl `renames' declarations.
61 It simultaneously performs dependency analysis and precedence parsing.
62 It also does the following error checks:
65 Checks that tyvars are used properly. This includes checking
66 for undefined tyvars, and tyvars in contexts that are ambiguous.
68 Checks that all variable occurences are defined.
70 Checks the (..) etc constraints in the export list.
74 %*********************************************************
76 \subsection{Value declarations}
78 %*********************************************************
81 rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
83 rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds ->
84 returnRn (ValD new_binds)
87 rnDecl (SigD (IfaceSig name ty id_infos loc))
89 lookupBndrRn name `thenRn` \ name' ->
90 rnHsType ty `thenRn` \ ty' ->
92 -- Get the pragma info, unless we should ignore it
93 (if opt_IgnoreIfacePragmas then
96 mapRn rnIdInfo id_infos
97 ) `thenRn` \ id_infos' ->
99 returnRn (SigD (IfaceSig name' ty' id_infos' loc))
102 %*********************************************************
104 \subsection{Type declarations}
106 %*********************************************************
108 @rnTyDecl@ uses the `global name function' to create a new type
109 declaration in which local names have been replaced by their original
110 names, reporting any unknown names.
112 Renaming type variables is a pain. Because they now contain uniques,
113 it is necessary to pass in an association list which maps a parsed
114 tyvar to its Name representation. In some cases (type signatures of
115 values), it is even necessary to go over the type first in order to
116 get the set of tyvars used by it, make an assoc list, and then go over
117 it again to rename the tyvars! However, we can also do some scoping
118 checks at the same time.
121 rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc))
122 = pushSrcLocRn src_loc $
123 lookupBndrRn tycon `thenRn` \ tycon' ->
124 bindTyVarsRn "data declaration" tyvars $ \ tyvars' ->
125 rnContext context `thenRn` \ context' ->
126 mapRn rnConDecl condecls `thenRn` \ condecls' ->
127 rnDerivs derivings `thenRn` \ derivings' ->
128 ASSERT(isNoDataPragmas pragmas)
129 returnRn (TyD (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
131 rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc))
132 = pushSrcLocRn src_loc $
133 lookupBndrRn tycon `thenRn` \ tycon' ->
134 bindTyVarsRn "newtype declaration" tyvars $ \ tyvars' ->
135 rnContext context `thenRn` \ context' ->
136 rnConDecl condecl `thenRn` \ condecl' ->
137 rnDerivs derivings `thenRn` \ derivings' ->
138 ASSERT(isNoDataPragmas pragmas)
139 returnRn (TyD (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc))
141 rnDecl (TyD (TySynonym name tyvars ty src_loc))
142 = pushSrcLocRn src_loc $
143 lookupBndrRn name `thenRn` \ name' ->
144 bindTyVarsRn "type declaration" tyvars $ \ tyvars' ->
145 rnHsType ty `thenRn` \ ty' ->
146 returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
149 %*********************************************************
151 \subsection{Class declarations}
153 %*********************************************************
155 @rnClassDecl@ uses the `global name function' to create a new
156 class declaration in which local names have been replaced by their
157 original names, reporting any unknown names.
160 rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
161 = pushSrcLocRn src_loc $
162 bindTyVarsRn "class declaration" [tyvar] $ \ [tyvar'] ->
163 rnContext context `thenRn` \ context' ->
164 lookupBndrRn cname `thenRn` \ cname' ->
165 mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
166 rnMethodBinds mbinds `thenRn` \ mbinds' ->
167 ASSERT(isNoClassPragmas pragmas)
168 returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc))
170 rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn)
171 = pushSrcLocRn locn $
173 dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
175 lookupBndrRn op `thenRn` \ op_name ->
176 newSysName dm_occ Exported locn `thenRn` \ dm_name ->
177 addOccurrenceName Optional dm_name `thenRn_`
178 -- Call up interface info for default method, if such info exists
180 rnHsType ty `thenRn` \ new_ty ->
182 (ctxt, op_ty) = case new_ty of
183 HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
184 other -> ([], new_ty)
185 ctxt_fvs = extractCtxtTyNames ctxt
186 op_ty_fvs = extractHsTyNames op_ty -- Includes tycons/classes but we
187 -- don't care about that
189 -- check that class tyvar appears in op_ty
190 checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
191 (classTyVarNotInOpTyErr clas_tyvar sig)
194 -- check that class tyvar *doesn't* appear in the sig's context
195 checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
196 (classTyVarInOpCtxtErr clas_tyvar sig)
199 -- ASSERT(isNoClassOpPragmas pragmas)
200 returnRn (ClassOpSig op_name dm_name new_ty locn)
204 %*********************************************************
206 \subsection{Instance declarations}
208 %*********************************************************
211 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
212 = pushSrcLocRn src_loc $
213 rnHsType inst_ty `thenRn` \ inst_ty' ->
214 rnMethodBinds mbinds `thenRn` \ mbinds' ->
215 mapRn rn_uprag uprags `thenRn` \ new_uprags ->
217 newDfunName maybe_dfun src_loc `thenRn` \ dfun_name ->
218 addOccurrenceName Compulsory dfun_name `thenRn_`
219 -- The dfun is not optional, because we use its version number
220 -- to identify the version of the instance declaration
222 returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc))
224 rn_uprag (SpecSig op ty using locn)
225 = pushSrcLocRn src_loc $
226 lookupBndrRn op `thenRn` \ op_name ->
227 rnHsType ty `thenRn` \ new_ty ->
228 rn_using using `thenRn` \ new_using ->
229 returnRn (SpecSig op_name new_ty new_using locn)
231 rn_uprag (InlineSig op locn)
232 = pushSrcLocRn locn $
233 lookupBndrRn op `thenRn` \ op_name ->
234 returnRn (InlineSig op_name locn)
236 rn_uprag (DeforestSig op locn)
237 = pushSrcLocRn locn $
238 lookupBndrRn op `thenRn` \ op_name ->
239 returnRn (DeforestSig op_name locn)
241 rn_uprag (MagicUnfoldingSig op str locn)
242 = pushSrcLocRn locn $
243 lookupBndrRn op `thenRn` \ op_name ->
244 returnRn (MagicUnfoldingSig op_name str locn)
246 rn_using Nothing = returnRn Nothing
247 rn_using (Just v) = lookupOccRn v `thenRn` \ new_v ->
248 returnRn (Just new_v)
251 %*********************************************************
253 \subsection{Default declarations}
255 %*********************************************************
258 rnDecl (DefD (DefaultDecl tys src_loc))
259 = pushSrcLocRn src_loc $
260 mapRn rnHsType tys `thenRn` \ tys' ->
261 lookupImplicitOccRn numClass_RDR `thenRn_`
262 returnRn (DefD (DefaultDecl tys' src_loc))
265 %*********************************************************
267 \subsection{Support code for type/data declarations}
269 %*********************************************************
272 rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
274 rnDerivs Nothing -- derivs not specified
275 = lookupImplicitOccRn evalClass_RDR `thenRn_`
279 = lookupImplicitOccRn evalClass_RDR `thenRn_`
280 mapRn rn_deriv ds `thenRn` \ derivs ->
281 returnRn (Just derivs)
284 = lookupOccRn clas `thenRn` \ clas_name ->
286 -- Now add extra "occurrences" for things that
287 -- the deriving mechanism will later need in order to
288 -- generate code for this class.
289 case lookupUFM derivingOccurrences clas_name of
290 Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_`
293 Just occs -> mapRn lookupImplicitOccRn occs `thenRn_`
298 rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
300 rnConDecl (ConDecl name tys src_loc)
301 = pushSrcLocRn src_loc $
302 checkConName name `thenRn_`
303 lookupBndrRn name `thenRn` \ new_name ->
304 mapRn rnBangTy tys `thenRn` \ new_tys ->
305 returnRn (ConDecl new_name new_tys src_loc)
307 rnConDecl (ConOpDecl ty1 op ty2 src_loc)
308 = pushSrcLocRn src_loc $
309 lookupBndrRn op `thenRn` \ new_op ->
310 rnBangTy ty1 `thenRn` \ new_ty1 ->
311 rnBangTy ty2 `thenRn` \ new_ty2 ->
312 returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
314 rnConDecl (NewConDecl name ty src_loc)
315 = pushSrcLocRn src_loc $
316 checkConName name `thenRn_`
317 lookupBndrRn name `thenRn` \ new_name ->
318 rnHsType ty `thenRn` \ new_ty ->
319 returnRn (NewConDecl new_name new_ty src_loc)
321 rnConDecl (RecConDecl name fields src_loc)
322 = pushSrcLocRn src_loc $
323 lookupBndrRn name `thenRn` \ new_name ->
324 mapRn rnField fields `thenRn` \ new_fields ->
325 returnRn (RecConDecl new_name new_fields src_loc)
328 = mapRn lookupBndrRn names `thenRn` \ new_names ->
329 rnBangTy ty `thenRn` \ new_ty ->
330 returnRn (new_names, new_ty)
333 = rnHsType ty `thenRn` \ new_ty ->
334 returnRn (Banged new_ty)
336 rnBangTy (Unbanged ty)
337 = rnHsType ty `thenRn` \ new_ty ->
338 returnRn (Unbanged new_ty)
340 -- This data decl will parse OK
342 -- treating "a" as the constructor.
343 -- It is really hard to make the parser spot this malformation.
344 -- So the renamer has to check that the constructor is legal
346 -- We can get an operator as the constructor, even in the prefix form:
347 -- data T = :% Int Int
348 -- from interface files, which always print in prefix form
351 = checkRn (isLexCon (occNameString (rdrNameOcc name)))
356 %*********************************************************
358 \subsection{Support code to rename types}
360 %*********************************************************
363 rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
365 rnHsType (HsForAllTy tvs ctxt ty)
366 = rn_poly_help tvs ctxt ty
368 rnHsType full_ty@(HsPreForAllTy ctxt ty)
369 = getNameEnv `thenRn` \ name_env ->
371 mentioned_tyvars = extractHsTyVars full_ty
372 forall_tyvars = filter not_in_scope mentioned_tyvars
373 not_in_scope tv = case lookupFM name_env tv of
377 rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
379 rnHsType (MonoTyVar tyvar)
380 = lookupOccRn tyvar `thenRn` \ tyvar' ->
381 returnRn (MonoTyVar tyvar')
383 rnHsType (MonoFunTy ty1 ty2)
384 = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
386 rnHsType (MonoListTy _ ty)
387 = lookupImplicitOccRn listType_RDR `thenRn` \ tycon_name ->
388 rnHsType ty `thenRn` \ ty' ->
389 returnRn (MonoListTy tycon_name ty')
391 rnHsType (MonoTupleTy _ tys)
392 = lookupImplicitOccRn (tupleType_RDR (length tys)) `thenRn` \ tycon_name ->
393 mapRn rnHsType tys `thenRn` \ tys' ->
394 returnRn (MonoTupleTy tycon_name tys')
396 rnHsType (MonoTyApp ty1 ty2)
397 = rnHsType ty1 `thenRn` \ ty1' ->
398 rnHsType ty2 `thenRn` \ ty2' ->
399 returnRn (MonoTyApp ty1' ty2')
401 rnHsType (MonoDictTy clas ty)
402 = lookupOccRn clas `thenRn` \ clas' ->
403 rnHsType ty `thenRn` \ ty' ->
404 returnRn (MonoDictTy clas' ty')
407 rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars
410 -> RnMS s RenamedHsType
412 rn_poly_help tyvars ctxt ty
413 = bindTyVarsRn "type signature" tyvars $ \ new_tyvars ->
414 rnContext ctxt `thenRn` \ new_ctxt ->
415 rnHsType ty `thenRn` \ new_ty ->
416 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
421 rnContext :: RdrNameContext -> RnMS s RenamedContext
424 = mapRn rn_ctxt ctxt `thenRn` \ result ->
426 (_, dup_asserts) = removeDups cmp_assert result
428 -- If this isn't an error, then it ought to be:
429 mapRn (addWarnRn . dupClassAssertWarn result) dup_asserts `thenRn_`
433 = lookupOccRn clas `thenRn` \ clas_name ->
434 rnHsType ty `thenRn` \ ty' ->
435 returnRn (clas_name, ty')
437 cmp_assert (c1,ty1) (c2,ty2)
438 = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2)
442 %*********************************************************
446 %*********************************************************
449 rnIdInfo (HsStrictness strict)
450 = rnStrict strict `thenRn` \ strict' ->
451 returnRn (HsStrictness strict')
453 rnIdInfo (HsUnfold expr) = rnCoreExpr expr `thenRn` \ expr' ->
454 returnRn (HsUnfold expr')
455 rnIdInfo (HsArity arity) = returnRn (HsArity arity)
456 rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
457 rnIdInfo (HsFBType fb) = returnRn (HsFBType fb)
458 rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
459 rnIdInfo (HsDeforest df) = returnRn (HsDeforest df)
461 rnStrict (StrictnessInfo demands (Just worker))
462 = lookupOptionalOccRn worker `thenRn` \ worker' ->
463 returnRn (StrictnessInfo demands (Just worker'))
465 -- Boring, but necessary for the type checker.
466 rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
467 rnStrict BottomGuaranteed = returnRn BottomGuaranteed
468 rnStrict NoStrictnessInfo = returnRn NoStrictnessInfo
475 = lookupOptionalOccRn v `thenRn` \ v' ->
478 rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
480 rnCoreExpr (UfCon con args)
481 = lookupOptionalOccRn con `thenRn` \ con' ->
482 mapRn rnCoreArg args `thenRn` \ args' ->
483 returnRn (UfCon con' args')
485 rnCoreExpr (UfPrim prim args)
486 = rnCorePrim prim `thenRn` \ prim' ->
487 mapRn rnCoreArg args `thenRn` \ args' ->
488 returnRn (UfPrim prim' args')
490 rnCoreExpr (UfApp fun arg)
491 = rnCoreExpr fun `thenRn` \ fun' ->
492 rnCoreArg arg `thenRn` \ arg' ->
493 returnRn (UfApp fun' arg')
495 rnCoreExpr (UfCase scrut alts)
496 = rnCoreExpr scrut `thenRn` \ scrut' ->
497 rnCoreAlts alts `thenRn` \ alts' ->
498 returnRn (UfCase scrut' alts')
500 rnCoreExpr (UfSCC cc expr)
501 = rnCoreExpr expr `thenRn` \ expr' ->
502 returnRn (UfSCC cc expr')
504 rnCoreExpr(UfCoerce coercion ty body)
505 = rnCoercion coercion `thenRn` \ coercion' ->
506 rnHsType ty `thenRn` \ ty' ->
507 rnCoreExpr body `thenRn` \ body' ->
508 returnRn (UfCoerce coercion' ty' body')
510 rnCoreExpr (UfLam bndr body)
511 = rnCoreBndr bndr $ \ bndr' ->
512 rnCoreExpr body `thenRn` \ body' ->
513 returnRn (UfLam bndr' body')
515 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
516 = rnCoreExpr rhs `thenRn` \ rhs' ->
517 rnCoreBndr bndr $ \ bndr' ->
518 rnCoreExpr body `thenRn` \ body' ->
519 returnRn (UfLet (UfNonRec bndr' rhs') body')
521 rnCoreExpr (UfLet (UfRec pairs) body)
522 = rnCoreBndrs bndrs $ \ bndrs' ->
523 mapRn rnCoreExpr rhss `thenRn` \ rhss' ->
524 rnCoreExpr body `thenRn` \ body' ->
525 returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
527 (bndrs, rhss) = unzip pairs
531 rnCoreBndr (UfValBinder name ty) thing_inside
532 = rnHsType ty `thenRn` \ ty' ->
533 bindLocalsRn "unfolding value" [name] $ \ [name'] ->
534 thing_inside (UfValBinder name' ty')
536 rnCoreBndr (UfTyBinder name kind) thing_inside
537 = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
538 thing_inside (UfTyBinder name' kind)
540 rnCoreBndr (UfUsageBinder name) thing_inside
541 = bindLocalsRn "unfolding usage" [name] $ \ [name'] ->
542 thing_inside (UfUsageBinder name')
544 rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders
545 = mapRn rnHsType tys `thenRn` \ tys' ->
546 bindLocalsRn "unfolding value" names $ \ names' ->
547 thing_inside (zipWith UfValBinder names' tys')
549 names = map (\ (UfValBinder name _) -> name) bndrs
550 tys = map (\ (UfValBinder _ ty) -> ty) bndrs
552 rnCoreBndrNamess names thing_inside
553 = bindLocalsRn "unfolding value" names $ \ names' ->
558 rnCoreArg (UfVarArg v) = lookupOptionalOccRn v `thenRn` \ v' -> returnRn (UfVarArg v')
559 rnCoreArg (UfUsageArg u) = lookupOptionalOccRn u `thenRn` \ u' -> returnRn (UfUsageArg u')
560 rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty')
561 rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
563 rnCoreAlts (UfAlgAlts alts deflt)
564 = mapRn rn_alt alts `thenRn` \ alts' ->
565 rnCoreDefault deflt `thenRn` \ deflt' ->
566 returnRn (UfAlgAlts alts' deflt')
568 rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' ->
569 bindLocalsRn "unfolding alt" bndrs $ \ bndrs' ->
570 rnCoreExpr rhs `thenRn` \ rhs' ->
571 returnRn (con', bndrs', rhs')
573 rnCoreAlts (UfPrimAlts alts deflt)
574 = mapRn rn_alt alts `thenRn` \ alts' ->
575 rnCoreDefault deflt `thenRn` \ deflt' ->
576 returnRn (UfPrimAlts alts' deflt')
578 rn_alt (lit, rhs) = rnCoreExpr rhs `thenRn` \ rhs' ->
581 rnCoreDefault UfNoDefault = returnRn UfNoDefault
582 rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr] $ \ [bndr'] ->
583 rnCoreExpr rhs `thenRn` \ rhs' ->
584 returnRn (UfBindDefault bndr' rhs')
586 rnCoercion (UfIn n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn n')
587 rnCoercion (UfOut n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfOut n')
589 rnCorePrim (UfOtherOp op)
590 = lookupOptionalOccRn op `thenRn` \ op' ->
591 returnRn (UfOtherOp op')
593 rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
594 = mapRn rnHsType arg_tys `thenRn` \ arg_tys' ->
595 rnHsType res_ty `thenRn` \ res_ty' ->
596 returnRn (UfCCallOp str casm gc arg_tys' res_ty')
599 %*********************************************************
603 %*********************************************************
606 derivingNonStdClassErr clas sty
607 = ppCat [ppPStr SLIT("non-standard class in deriving:"), ppr sty clas]
609 classTyVarNotInOpTyErr clas_tyvar sig sty
610 = ppHang (ppBesides [ppPStr SLIT("Class type variable `"),
612 ppPStr SLIT("' does not appear in method signature:")])
615 classTyVarInOpCtxtErr clas_tyvar sig sty
616 = ppHang (ppBesides [ ppPStr SLIT("Class type variable `"), ppr sty clas_tyvar,
617 ppPStr SLIT("' present in method's local overloading context:")])
620 dupClassAssertWarn ctxt dups sty
621 = ppHang (ppBesides [ppPStr SLIT("Duplicate class assertion `"),
623 ppPStr SLIT("' in context:")])
627 = ppCat [ppPStr SLIT("Illegal data constructor name:"), ppr sty name]
634 =================== OLD STUFF ======================
636 %*********************************************************
638 \subsection{SPECIALIZE data pragmas}
640 %*********************************************************
643 rnSpecDataSig :: RdrNameSpecDataSig
644 -> RnMS s RenamedSpecDataSig
646 rnSpecDataSig (SpecDataSig tycon ty src_loc)
647 = pushSrcLocRn src_loc $
649 tyvars = filter extractHsTyNames ty
651 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
652 lookupOccRn tycon `thenRn` \ tycon' ->
653 rnHsType tv_env ty `thenRn` \ ty' ->
654 returnRn (SpecDataSig tycon' ty' src_loc)
658 %*********************************************************
660 \subsection{@SPECIALIZE instance@ user-pragmas}
662 %*********************************************************
665 rnSpecInstSig :: RdrNameSpecInstSig
666 -> RnMS s RenamedSpecInstSig
668 rnSpecInstSig (SpecInstSig clas ty src_loc)
669 = pushSrcLocRn src_loc $
671 tyvars = extractHsTyNames is_tyvar_name ty
673 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
674 lookupOccRn clas `thenRn` \ new_clas ->
675 rnHsType tv_env ty `thenRn` \ new_ty ->
676 returnRn (SpecInstSig new_clas new_ty src_loc)