2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
9 rnHsType, rnLHsType, rnLHsTypes, rnContext,
10 rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred,
12 -- Precence related stuff
13 mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
14 checkPrecMatch, checkSectionPrec,
16 -- Splice related stuff
20 import {-# SOURCE #-} RnExpr( rnLExpr )
22 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
27 import RdrHsSyn ( extractHsRhoRdrTyVars )
28 import RnHsSyn ( extractHsTyNames )
29 import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
34 import TypeRep ( funTyConName )
39 import BasicTypes ( compareFixity, funTyFixity, negateFixity,
40 Fixity(..), FixityDirection(..) )
43 import Control.Monad ( unless )
45 #include "HsVersions.h"
48 These type renamers are in a separate module, rather than in (say) RnSource,
49 to break several loop.
51 %*********************************************************
53 \subsection{Renaming types}
55 %*********************************************************
58 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
59 rnHsTypeFVs doc_str ty = do
60 ty' <- rnLHsType doc_str ty
61 return (ty', extractHsTyNames ty')
63 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
64 -- rnHsSigType is used for source-language type signatures,
65 -- which use *implicit* universal quantification.
66 rnHsSigType doc_str ty
67 = rnLHsType (text "In the type signature for" <+> doc_str) ty
70 rnHsType is here because we call it from loadInstDecl, and I didn't
71 want a gratuitous knot.
74 rnLHsType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
75 rnLHsType doc = wrapLocM (rnHsType doc)
77 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
79 rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
80 -- Implicit quantifiction in source code (no kinds on tyvars)
81 -- Given the signature C => T we universally quantify
82 -- over FV(T) \ {in-scope-tyvars}
83 name_env <- getLocalRdrEnv
85 mentioned = extractHsRhoRdrTyVars ctxt ty
87 -- Don't quantify over type variables that are in scope;
88 -- when GlasgowExts is off, there usually won't be any, except for
90 -- class C a where { op :: a -> a }
91 forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
92 tyvar_bndrs = userHsTyVarBndrs forall_tyvars
94 rnForAll doc Implicit tyvar_bndrs ctxt ty
96 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
97 -- Explicit quantification.
98 -- Check that the forall'd tyvars are actually
99 -- mentioned in the type, and produce a warning if not
101 mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau)
102 forall_tyvar_names = hsLTyVarLocNames forall_tyvars
104 -- Explicitly quantified but not mentioned in ctxt or tau
105 warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
107 mapM_ (forAllWarn doc tau) warn_guys
108 rnForAll doc Explicit forall_tyvars ctxt tau
110 rnHsType _ (HsTyVar tyvar) = do
111 tyvar' <- lookupOccRn tyvar
112 return (HsTyVar tyvar')
114 -- If we see (forall a . ty), without foralls on, the forall will give
115 -- a sensible error message, but we don't want to complain about the dot too
116 -- Hence the jiggery pokery with ty1
117 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
119 do { ops_ok <- xoptM Opt_TypeOperators
122 else do { addErr (opTyErr op ty)
123 ; return (mkUnboundName op) } -- Avoid double complaint
124 ; let l_op' = L loc op'
125 ; fix <- lookupTyFixityRn l_op'
126 ; ty1' <- rnLHsType doc ty1
127 ; ty2' <- rnLHsType doc ty2
128 ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
130 rnHsType doc (HsParTy ty) = do
131 ty' <- rnLHsType doc ty
134 rnHsType doc (HsBangTy b ty)
135 = do { ty' <- rnLHsType doc ty
136 ; return (HsBangTy b ty') }
138 rnHsType doc (HsRecTy flds)
139 = do { flds' <- rnConDeclFields doc flds
140 ; return (HsRecTy flds') }
142 rnHsType _ (HsNumTy i)
143 | i == 1 = return (HsNumTy i)
144 | otherwise = addErr err_msg >> return (HsNumTy i)
146 err_msg = ptext (sLit "Only unit numeric type pattern is valid")
149 rnHsType doc (HsFunTy ty1 ty2) = do
150 ty1' <- rnLHsType doc ty1
151 -- Might find a for-all as the arg of a function type
152 ty2' <- rnLHsType doc ty2
153 -- Or as the result. This happens when reading Prelude.hi
154 -- when we find return :: forall m. Monad m -> forall a. a -> m a
156 -- Check for fixity rearrangements
157 mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
159 rnHsType doc (HsListTy ty) = do
160 ty' <- rnLHsType doc ty
161 return (HsListTy ty')
163 rnHsType doc (HsKindSig ty k)
164 = do { kind_sigs_ok <- xoptM Opt_KindSignatures
165 ; unless kind_sigs_ok (addErr (kindSigErr ty))
166 ; ty' <- rnLHsType doc ty
167 ; return (HsKindSig ty' k) }
169 rnHsType doc (HsPArrTy ty) = do
170 ty' <- rnLHsType doc ty
171 return (HsPArrTy ty')
173 rnHsType doc (HsModalBoxType ecn ty) = do
174 ecn' <- lookupOccRn ecn
175 ty' <- rnLHsType doc ty
176 return (HsModalBoxType ecn' ty')
178 -- Unboxed tuples are allowed to have poly-typed arguments. These
179 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
180 rnHsType doc (HsTupleTy tup_con tys) = do
181 tys' <- mapM (rnLHsType doc) tys
182 return (HsTupleTy tup_con tys')
184 rnHsType doc (HsAppTy ty1 ty2) = do
185 ty1' <- rnLHsType doc ty1
186 ty2' <- rnLHsType doc ty2
187 return (HsAppTy ty1' ty2')
189 rnHsType doc (HsPredTy pred) = do
190 pred' <- rnPred doc pred
191 return (HsPredTy pred')
193 rnHsType _ (HsSpliceTy sp _ k)
194 = do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs
195 ; return (HsSpliceTy sp' fvs k) }
197 rnHsType doc (HsDocTy ty haddock_doc) = do
198 ty' <- rnLHsType doc ty
199 haddock_doc' <- rnLHsDoc haddock_doc
200 return (HsDocTy ty' haddock_doc')
203 rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
205 rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
206 ; rnHsType doc (unLoc ty) }
208 rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty)
211 rnLHsTypes :: SDoc -> [LHsType RdrName]
212 -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
213 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
218 rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
219 -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
221 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
222 -- One reason for this case is that a type like Int#
223 -- starts off as (HsForAllTy Nothing [] Int), in case
224 -- there is some quantification. Now that we have quantified
225 -- and discovered there are no type variables, it's nicer to turn
226 -- it into plain Int. If it were Int# instead of Int, we'd actually
227 -- get an error, because the body of a genuine for-all is
230 rnForAll doc exp forall_tyvars ctxt ty
231 = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
232 new_ctxt <- rnContext doc ctxt
233 new_ty <- rnLHsType doc ty
234 return (HsForAllTy exp new_tyvars new_ctxt new_ty)
235 -- Retain the same implicit/explicit flag as before
236 -- so that we can later print it correctly
238 rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
239 rnConDeclFields doc fields = mapM (rnField doc) fields
241 rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
242 rnField doc (ConDeclField name ty haddock_doc)
243 = do { new_name <- lookupLocatedTopBndrRn name
244 ; new_ty <- rnLHsType doc ty
245 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
246 ; return (ConDeclField new_name new_ty new_haddock_doc) }
249 %*********************************************************
251 \subsection{Contexts and predicates}
253 %*********************************************************
256 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
257 rnContext doc = wrapLocM (rnContext' doc)
259 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
260 rnContext' doc ctxt = mapM (rnLPred doc) ctxt
262 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
263 rnLPred doc = wrapLocM (rnPred doc)
265 rnPred :: SDoc -> HsPred RdrName
266 -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
267 rnPred doc (HsClassP clas tys)
268 = do { clas_name <- lookupOccRn clas
269 ; tys' <- rnLHsTypes doc tys
270 ; return (HsClassP clas_name tys')
272 rnPred doc (HsEqualP ty1 ty2)
273 = do { ty1' <- rnLHsType doc ty1
274 ; ty2' <- rnLHsType doc ty2
275 ; return (HsEqualP ty1' ty2')
277 rnPred doc (HsIParam n ty)
278 = do { name <- newIPNameRn n
279 ; ty' <- rnLHsType doc ty
280 ; return (HsIParam name ty')
285 %************************************************************************
287 Fixities and precedence parsing
289 %************************************************************************
291 @mkOpAppRn@ deals with operator fixities. The argument expressions
292 are assumed to be already correctly arranged. It needs the fixities
293 recorded in the OpApp nodes, because fixity info applies to the things
294 the programmer actually wrote, so you can't find it out from the Name.
296 Furthermore, the second argument is guaranteed not to be another
297 operator application. Why? Because the parser parses all
298 operator appications left-associatively, EXCEPT negation, which
299 we need to handle specially.
300 Infix types are read in a *right-associative* way, so that
305 mkHsOpTyRn rearranges where necessary. The two arguments
306 have already been renamed and rearranged. It's made rather tiresome
307 by the presence of ->, which is a separate syntactic construct.
311 -- Building (ty1 `op1` (ty21 `op2` ty22))
312 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
313 -> Name -> Fixity -> LHsType Name -> LHsType Name
316 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
317 = do { fix2 <- lookupTyFixityRn op2
318 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
319 (\t1 t2 -> HsOpTy t1 op2 t2)
320 (unLoc op2) fix2 ty21 ty22 loc2 }
322 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
323 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
324 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
326 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
327 = return (mk1 ty1 ty2)
330 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
331 -> Name -> Fixity -> LHsType Name
332 -> (LHsType Name -> LHsType Name -> HsType Name)
333 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
335 mk_hs_op_ty mk1 op1 fix1 ty1
336 mk2 op2 fix2 ty21 ty22 loc2
337 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
338 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
339 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
340 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
341 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
342 ; return (mk2 (noLoc new_ty) ty22) }
344 (nofix_error, associate_right) = compareFixity fix1 fix2
347 ---------------------------
348 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
349 -> LHsExpr Name -> Fixity -- Operator and fixity
350 -> LHsExpr Name -- Right operand (not an OpApp, but might
354 -- (e11 `op1` e12) `op2` e2
355 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
357 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
358 return (OpApp e1 op2 fix2 e2)
360 | associate_right = do
361 new_e <- mkOpAppRn e12 op2 fix2 e2
362 return (OpApp e11 op1 fix1 (L loc' new_e))
364 loc'= combineLocs e12 e2
365 (nofix_error, associate_right) = compareFixity fix1 fix2
367 ---------------------------
368 -- (- neg_arg) `op` e2
369 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
371 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
372 return (OpApp e1 op2 fix2 e2)
375 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
376 return (NegApp (L loc' new_e) neg_name)
378 loc' = combineLocs neg_arg e2
379 (nofix_error, associate_right) = compareFixity negateFixity fix2
381 ---------------------------
383 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
384 | not associate_right -- We *want* right association
385 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
386 return (OpApp e1 op1 fix1 e2)
388 (_, associate_right) = compareFixity fix1 negateFixity
390 ---------------------------
392 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
393 = ASSERT2( right_op_ok fix (unLoc e2),
394 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
396 return (OpApp e1 op fix e2)
398 ----------------------------
399 get_op :: LHsExpr Name -> Name
400 get_op (L _ (HsVar n)) = n
401 get_op other = pprPanic "get_op" (ppr other)
403 -- Parser left-associates everything, but
404 -- derived instances may have correctly-associated things to
405 -- in the right operarand. So we just check that the right operand is OK
406 right_op_ok :: Fixity -> HsExpr Name -> Bool
407 right_op_ok fix1 (OpApp _ _ fix2 _)
408 = not error_please && associate_right
410 (error_please, associate_right) = compareFixity fix1 fix2
414 -- Parser initially makes negation bind more tightly than any other operator
415 -- And "deriving" code should respect this (use HsPar if not)
416 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
417 mkNegAppRn neg_arg neg_name
418 = ASSERT( not_op_app (unLoc neg_arg) )
419 return (NegApp neg_arg neg_name)
421 not_op_app :: HsExpr id -> Bool
422 not_op_app (OpApp _ _ _ _) = False
425 ---------------------------
426 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
427 -> LHsExpr Name -> Fixity -- Operator and fixity
428 -> LHsCmdTop Name -- Right operand (not an infix)
431 -- (e11 `op1` e12) `op2` e2
432 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
435 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
436 return (HsArrForm op2 (Just fix2) [a1, a2])
439 = do new_c <- mkOpFormRn a12 op2 fix2 a2
440 return (HsArrForm op1 (Just fix1)
441 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
442 -- TODO: locs are wrong
444 (nofix_error, associate_right) = compareFixity fix1 fix2
447 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
448 = return (HsArrForm op (Just fix) [arg1, arg2])
451 --------------------------------------
452 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
455 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
456 = do { fix1 <- lookupFixityRn (unLoc op1)
457 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
459 ; if nofix_error then do
460 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
461 ; return (ConPatIn op2 (InfixCon p1 p2)) }
463 else if associate_right then do
464 { new_p <- mkConOpPatRn op2 fix2 p12 p2
465 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
466 else return (ConPatIn op2 (InfixCon p1 p2)) }
468 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
469 = ASSERT( not_op_pat (unLoc p2) )
470 return (ConPatIn op (InfixCon p1 p2))
472 not_op_pat :: Pat Name -> Bool
473 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
476 --------------------------------------
477 checkPrecMatch :: Name -> MatchGroup Name -> RnM ()
478 -- Check precedence of a function binding written infix
479 -- eg a `op` b `C` c = ...
480 -- See comments with rnExpr (OpApp ...) about "deriving"
482 checkPrecMatch op (MatchGroup ms _)
485 check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
486 = setSrcSpan (combineSrcSpans l1 l2) $
487 do checkPrec op p1 False
491 -- This can happen. Consider
494 -- The infix flag comes from the first binding of the group
495 -- but the second eqn has no args (an error, but not discovered
496 -- until the type checker). So we don't want to crash on the
499 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
500 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
501 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
502 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
504 inf_ok = op1_prec > op_prec ||
505 (op1_prec == op_prec &&
506 (op1_dir == InfixR && op_dir == InfixR && right ||
507 op1_dir == InfixL && op_dir == InfixL && not right))
510 info1 = (unLoc op1, op1_fix)
511 (infol, infor) = if right then (info, info1) else (info1, info)
512 unless inf_ok (precParseErr infol infor)
517 -- Check precedence of (arg op) or (op arg) respectively
518 -- If arg is itself an operator application, then either
519 -- (a) its precedence must be higher than that of op
520 -- (b) its precedency & associativity must be the same as that of op
521 checkSectionPrec :: FixityDirection -> HsExpr RdrName
522 -> LHsExpr Name -> LHsExpr Name -> RnM ()
523 checkSectionPrec direction section op arg
525 OpApp _ op fix _ -> go_for_it (get_op op) fix
526 NegApp _ _ -> go_for_it negateName negateFixity
530 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
531 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
532 unless (op_prec < arg_prec
533 || (op_prec == arg_prec && direction == assoc))
534 (sectionPrecErr (op_name, op_fix)
535 (arg_op, arg_fix) section)
538 Precedence-related error messages
541 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
542 precParseErr op1@(n1,_) op2@(n2,_)
543 | isUnboundName n1 || isUnboundName n2
544 = return () -- Avoid error cascade
546 = addErr $ hang (ptext (sLit "Precedence parsing error"))
547 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
549 ptext (sLit "in the same infix expression")])
551 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
552 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
553 | isUnboundName n1 || isUnboundName n2
554 = return () -- Avoid error cascade
556 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
557 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
558 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
559 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
561 ppr_opfix :: (Name, Fixity) -> SDoc
562 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
564 pp_op | op == negateName = ptext (sLit "prefix `-'")
565 | otherwise = quotes (ppr op)
568 %*********************************************************
572 %*********************************************************
575 forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
576 -> TcRnIf TcGblEnv TcLclEnv ()
577 forAllWarn doc ty (L loc tyvar)
578 = ifDOptM Opt_WarnUnusedMatches $
579 addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
580 nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
584 opTyErr :: RdrName -> HsType RdrName -> SDoc
585 opTyErr op ty@(HsOpTy ty1 _ _)
586 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
589 extra | op == dot_tv_RDR && forall_head ty1
592 = ptext (sLit "Use -XTypeOperators to allow operators in types")
594 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
595 forall_head (L _ (HsAppTy ty _)) = forall_head ty
596 forall_head _other = False
597 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
600 %*********************************************************
604 %*********************************************************
610 h = ...$(thing "f")...
612 The splice can expand into literally anything, so when we do dependency
613 analysis we must assume that it might mention 'f'. So we simply treat
614 all locally-defined names as mentioned by any splice. This is terribly
615 brutal, but I don't see what else to do. For example, it'll mean
616 that every locally-defined thing will appear to be used, so no unused-binding
617 warnings. But if we miss the dependency, then we might typecheck 'h' before 'f',
618 and that will crash the type checker because 'f' isn't in scope.
620 Currently, I'm not treating a splice as also mentioning every import,
621 which is a bit inconsistent -- but there are a lot of them. We might
622 thereby get some bogus unused-import warnings, but we won't crash the
623 type checker. Not very satisfactory really.
626 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
627 rnSplice (HsSplice n expr)
628 = do { checkTH expr "splice"
630 ; n' <- newLocalBndrRn (L loc n)
631 ; (expr', fvs) <- rnLExpr expr
633 -- Ugh! See Note [Splices] above
634 ; lcl_rdr <- getLocalRdrEnv
635 ; gbl_rdr <- getGlobalRdrEnv
636 ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
638 lcl_names = mkNameSet (occEnvElts lcl_rdr)
640 ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
642 checkTH :: Outputable a => a -> String -> RnM ()
644 checkTH _ _ = return () -- OK
646 checkTH e what -- Raise an error in a stage-1 compiler
647 = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
648 ptext (sLit "illegal in a stage-1 compiler"),