073ddaa12118c0a0c1bade40b1074d43f7ba4206
[ghc.git] / compiler / rename / RnSplice.hs
1 {-# LANGUAGE CPP #-}
2
3 module RnSplice (
4 rnTopSpliceDecls,
5 rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
6 rnBracket,
7 checkThLocalName
8 #ifdef GHCI
9 , traceSplice, SpliceInfo(..)
10 #endif
11 ) where
12
13 #include "HsVersions.h"
14
15 import Name
16 import NameSet
17 import HsSyn
18 import RdrName
19 import TcRnMonad
20 import Kind
21
22 import RnEnv
23 import RnSource ( rnSrcDecls, findSplice )
24 import RnPat ( rnPat )
25 import BasicTypes ( TopLevelFlag, isTopLevel )
26 import Outputable
27 import Module
28 import SrcLoc
29 import DynFlags
30 import FastString
31 import RnTypes ( rnLHsType )
32
33 import Control.Monad ( unless, when )
34
35 import {-# SOURCE #-} RnExpr ( rnLExpr )
36
37 import PrelNames ( isUnboundName )
38 import TcEnv ( checkWellStaged )
39 import THNames ( liftName )
40
41 #ifdef GHCI
42 import ErrUtils ( dumpIfSet_dyn_printer )
43 import TcEnv ( tcMetaTy )
44 import Hooks
45 import Var ( Id )
46 import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
47 , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
48 import RnTypes ( collectWildCards )
49 import Util
50
51 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
52 import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
53 #endif
54
55 {-
56 ************************************************************************
57 * *
58 Template Haskell brackets
59 * *
60 ************************************************************************
61 -}
62
63 rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
64 rnBracket e br_body
65 = addErrCtxt (quotationCtxtDoc br_body) $
66 do { -- Check that Template Haskell is enabled and available
67 thEnabled <- xoptM Opt_TemplateHaskell
68 ; unless thEnabled $
69 failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e
70 , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] )
71
72 -- Check for nested brackets
73 ; cur_stage <- getStage
74 ; case cur_stage of
75 { Splice True -> checkTc (isTypedBracket br_body) illegalUntypedBracket
76 ; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket
77 ; Comp -> return ()
78 ; Brack {} -> failWithTc illegalBracket
79 }
80
81 -- Brackets are desugared to code that mentions the TH package
82 ; recordThUse
83
84 ; case isTypedBracket br_body of
85 True -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $
86 rn_bracket cur_stage br_body
87 ; return (HsBracket body', fvs_e) }
88
89 False -> do { ps_var <- newMutVar []
90 ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
91 rn_bracket cur_stage br_body
92 ; pendings <- readMutVar ps_var
93 ; return (HsRnBracketOut body' pendings, fvs_e) }
94 }
95
96 rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
97 rn_bracket outer_stage br@(VarBr flg rdr_name)
98 = do { name <- lookupOccRn rdr_name
99 ; this_mod <- getModule
100
101 ; when (flg && nameIsLocalOrFrom this_mod name) $
102 -- Type variables can be quoted in TH. See #5721.
103 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
104 ; case mb_bind_lvl of
105 { Nothing -> return () -- Can happen for data constructors,
106 -- but nothing needs to be done for them
107
108 ; Just (top_lvl, bind_lvl) -- See Note [Quoting names]
109 | isTopLevel top_lvl
110 -> when (isExternalName name) (keepAlive name)
111 | otherwise
112 -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
113 ; checkTc (thLevel outer_stage + 1 == bind_lvl)
114 (quotedNameStageErr br) }
115 }
116 }
117 ; return (VarBr flg name, unitFV name) }
118
119 rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
120 ; return (ExpBr e', fvs) }
121
122 rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
123
124 rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
125 ; return (TypBr t', fvs) }
126
127 rn_bracket _ (DecBrL decls)
128 = do { group <- groupDecls decls
129 ; gbl_env <- getGblEnv
130 ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
131 -- The emptyDUs is so that we just collect uses for this
132 -- group alone in the call to rnSrcDecls below
133 ; (tcg_env, group') <- setGblEnv new_gbl_env $
134 rnSrcDecls group
135
136 -- Discard the tcg_env; it contains only extra info about fixity
137 ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
138 ppr (duUses (tcg_dus tcg_env))))
139 ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
140 where
141 groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)
142 groupDecls decls
143 = do { (group, mb_splice) <- findSplice decls
144 ; case mb_splice of
145 { Nothing -> return group
146 ; Just (splice, rest) ->
147 do { group' <- groupDecls rest
148 ; let group'' = appendGroups group group'
149 ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }
150 }
151 }}
152
153 rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
154
155 rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
156 ; return (TExpBr e', fvs) }
157
158 quotationCtxtDoc :: HsBracket RdrName -> SDoc
159 quotationCtxtDoc br_body
160 = hang (ptext (sLit "In the Template Haskell quotation"))
161 2 (ppr br_body)
162
163 illegalBracket :: SDoc
164 illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
165
166 illegalTypedBracket :: SDoc
167 illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.")
168
169 illegalUntypedBracket :: SDoc
170 illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.")
171
172 quotedNameStageErr :: HsBracket RdrName -> SDoc
173 quotedNameStageErr br
174 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
175 , ptext (sLit "must be used at the same stage at which is is bound")]
176
177 #ifndef GHCI
178 rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
179 rnTopSpliceDecls e = failTH e "Template Haskell top splice"
180
181 rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
182 -> RnM (HsType Name, FreeVars)
183 rnSpliceType e _ = failTH e "Template Haskell type splice"
184
185 rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
186 rnSpliceExpr e = failTH e "Template Haskell splice"
187
188 rnSplicePat :: HsSplice RdrName -> RnM (Either (Pat RdrName) (Pat Name), FreeVars)
189 rnSplicePat e = failTH e "Template Haskell pattern splice"
190
191 rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
192 rnSpliceDecl e = failTH e "Template Haskell declaration splice"
193 #else
194
195 {-
196 *********************************************************
197 * *
198 Splices
199 * *
200 *********************************************************
201
202 Note [Free variables of typed splices]
203 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
204 Consider renaming this:
205 f = ...
206 h = ...$(thing "f")...
207
208 where the splice is a *typed* splice. The splice can expand into
209 literally anything, so when we do dependency analysis we must assume
210 that it might mention 'f'. So we simply treat all locally-defined
211 names as mentioned by any splice. This is terribly brutal, but I
212 don't see what else to do. For example, it'll mean that every
213 locally-defined thing will appear to be used, so no unused-binding
214 warnings. But if we miss the dependency, then we might typecheck 'h'
215 before 'f', and that will crash the type checker because 'f' isn't in
216 scope.
217
218 Currently, I'm not treating a splice as also mentioning every import,
219 which is a bit inconsistent -- but there are a lot of them. We might
220 thereby get some bogus unused-import warnings, but we won't crash the
221 type checker. Not very satisfactory really.
222
223 Note [Renamer errors]
224 ~~~~~~~~~~~~~~~~~~~~~
225 It's important to wrap renamer calls in checkNoErrs, because the
226 renamer does not fail for out of scope variables etc. Instead it
227 returns a bogus term/type, so that it can report more than one error.
228 We don't want the type checker to see these bogus unbound variables.
229 -}
230
231 rnSpliceGen :: (HsSplice Name -> RnM (a, FreeVars)) -- Outside brackets, run splice
232 -> (HsSplice Name -> (PendingRnSplice, a)) -- Inside brackets, make it pending
233 -> HsSplice RdrName
234 -> RnM (a, FreeVars)
235 rnSpliceGen run_splice pend_splice splice
236 = addErrCtxt (spliceCtxt splice) $ do
237 { stage <- getStage
238 ; case stage of
239 Brack pop_stage RnPendingTyped
240 -> do { checkTc is_typed_splice illegalUntypedSplice
241 ; (splice', fvs) <- setStage pop_stage $
242 rnSplice splice
243 ; let (_pending_splice, result) = pend_splice splice'
244 ; return (result, fvs) }
245
246 Brack pop_stage (RnPendingUntyped ps_var)
247 -> do { checkTc (not is_typed_splice) illegalTypedSplice
248 ; (splice', fvs) <- setStage pop_stage $
249 rnSplice splice
250 ; let (pending_splice, result) = pend_splice splice'
251 ; ps <- readMutVar ps_var
252 ; writeMutVar ps_var (pending_splice : ps)
253 ; return (result, fvs) }
254
255 _ -> do { (splice', fvs1) <- checkNoErrs $
256 setStage (Splice is_typed_splice) $
257 rnSplice splice
258 -- checkNoErrs: don't attempt to run the splice if
259 -- renaming it failed; otherwise we get a cascade of
260 -- errors from e.g. unbound variables
261 ; (result, fvs2) <- run_splice splice'
262 ; return (result, fvs1 `plusFV` fvs2) } }
263 where
264 is_typed_splice = isTypedSplice splice
265
266 ------------------
267 runRnSplice :: UntypedSpliceFlavour
268 -> (LHsExpr Id -> TcRn res)
269 -> (res -> SDoc) -- How to pretty-print res
270 -- Usually just ppr, but not for [Decl]
271 -> HsSplice Name -- Always untyped
272 -> TcRn res
273 runRnSplice flavour run_meta ppr_res splice
274 = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
275
276 ; let the_expr = case splice' of
277 HsUntypedSplice _ e -> e
278 HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
279 HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
280
281 -- Typecheck the expression
282 ; meta_exp_ty <- tcMetaTy meta_ty_name
283 ; zonked_q_expr <- tcTopSpliceExpr False $
284 tcMonoExpr the_expr meta_exp_ty
285
286 -- Run the expression
287 ; result <- run_meta zonked_q_expr
288 ; traceSplice (SpliceInfo { spliceDescription = what
289 , spliceIsDecl = is_decl
290 , spliceSource = Just the_expr
291 , spliceGenerated = ppr_res result })
292
293 ; return result }
294
295 where
296 meta_ty_name = case flavour of
297 UntypedExpSplice -> expQTyConName
298 UntypedPatSplice -> patQTyConName
299 UntypedTypeSplice -> typeQTyConName
300 UntypedDeclSplice -> decsQTyConName
301 what = case flavour of
302 UntypedExpSplice -> "expression"
303 UntypedPatSplice -> "pattern"
304 UntypedTypeSplice -> "type"
305 UntypedDeclSplice -> "declarations"
306 is_decl = case flavour of
307 UntypedDeclSplice -> True
308 _ -> False
309
310 ------------------
311 makePending :: UntypedSpliceFlavour
312 -> HsSplice Name
313 -> PendingRnSplice
314 makePending flavour (HsUntypedSplice n e)
315 = PendingRnSplice flavour n e
316 makePending flavour (HsQuasiQuote n quoter q_span quote)
317 = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
318 makePending _ splice@(HsTypedSplice {})
319 = pprPanic "makePending" (ppr splice)
320
321 ------------------
322 mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name
323 -- Return the expression (quoter "...quote...")
324 -- which is what we must run in a quasi-quote
325 mkQuasiQuoteExpr flavour quoter q_span quote
326 = L q_span $ HsApp (L q_span $
327 HsApp (L q_span (HsVar quote_selector)) quoterExpr)
328 quoteExpr
329 where
330 quoterExpr = L q_span $! HsVar $! quoter
331 quoteExpr = L q_span $! HsLit $! HsString "" quote
332 quote_selector = case flavour of
333 UntypedExpSplice -> quoteExpName
334 UntypedPatSplice -> quotePatName
335 UntypedTypeSplice -> quoteTypeName
336 UntypedDeclSplice -> quoteDecName
337
338 ---------------------
339 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
340 -- Not exported...used for all
341 rnSplice (HsTypedSplice splice_name expr)
342 = do { checkTH expr "Template Haskell typed splice"
343 ; loc <- getSrcSpanM
344 ; n' <- newLocalBndrRn (L loc splice_name)
345 ; (expr', fvs) <- rnLExpr expr
346 ; return (HsTypedSplice n' expr', fvs) }
347
348 rnSplice (HsUntypedSplice splice_name expr)
349 = do { checkTH expr "Template Haskell untyped splice"
350 ; loc <- getSrcSpanM
351 ; n' <- newLocalBndrRn (L loc splice_name)
352 ; (expr', fvs) <- rnLExpr expr
353 ; return (HsUntypedSplice n' expr', fvs) }
354
355 rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
356 = do { checkTH quoter "Template Haskell quasi-quote"
357 ; loc <- getSrcSpanM
358 ; splice_name' <- newLocalBndrRn (L loc splice_name)
359
360 -- Drop the leading "$" from the quoter name, if present
361 -- This is old-style syntax, now deprecated
362 -- NB: when removing this backward-compat, remove
363 -- the matching code in Lexer.x (around line 310)
364 ; let occ_str = occNameString (rdrNameOcc quoter)
365 ; quoter <- if ASSERT( not (null occ_str) ) -- Lexer ensures this
366 head occ_str /= '$'
367 then return quoter
368 else do { addWarn (deprecatedDollar quoter)
369 ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }
370
371 -- Rename the quoter; akin to the HsVar case of rnExpr
372 ; quoter' <- lookupOccRn quoter
373 ; this_mod <- getModule
374 ; when (nameIsLocalOrFrom this_mod quoter') $
375 checkThLocalName quoter'
376
377 ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }
378
379 deprecatedDollar :: RdrName -> SDoc
380 deprecatedDollar quoter
381 = hang (ptext (sLit "Deprecated syntax:"))
382 2 (ptext (sLit "quasiquotes no longer need a dollar sign:")
383 <+> ppr quoter)
384
385
386 ---------------------
387 rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
388 rnSpliceExpr splice
389 = rnSpliceGen run_expr_splice pend_expr_splice splice
390 where
391 pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name)
392 pend_expr_splice rn_splice
393 = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice)
394
395 run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars)
396 run_expr_splice rn_splice
397 | isTypedSplice rn_splice -- Run it later, in the type checker
398 = do { -- Ugh! See Note [Splices] above
399 lcl_rdr <- getLocalRdrEnv
400 ; gbl_rdr <- getGlobalRdrEnv
401 ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
402 , isLocalGRE gre]
403 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
404
405 ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
406
407 | otherwise -- Run it here
408 = do { rn_expr <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice
409 ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
410 ; return (HsPar lexpr3, fvs) }
411
412 ----------------------
413 rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
414 -> RnM (HsType Name, FreeVars)
415 rnSpliceType splice k
416 = rnSpliceGen run_type_splice pend_type_splice splice
417 where
418 pend_type_splice rn_splice
419 = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
420
421 run_type_splice rn_splice
422 = do { hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
423 ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
424 ; checkValidPartialTypeSplice doc hs_ty2
425 -- See Note [Partial Type Splices]
426 ; checkNoErrs $ rnLHsType doc hs_ty2 }
427 -- checkNoErrs: see Note [Renamer errors]
428 ; return (HsParTy hs_ty3, fvs) }
429 -- Wrap the result of the splice in parens so that we don't
430 -- lose the outermost location set by runQuasiQuote (#7918)
431 {-
432 Note [Partial Type Splices]
433 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
434
435 Partial Type Signatures are partially supported in TH type splices: only
436 anonymous wild cards are allowed.
437
438 Normally, named wild cards are collected before renaming a (partial) type
439 signature. However, TH type splices are run during renaming, i.e. after the
440 initial traversal, leading to out of scope errors for named wild cards. We
441 can't just extend the initial traversal to collect the named wild cards in TH
442 type splices, as we'd need to expand them, which is supposed to happen only
443 once, during renaming.
444
445 Similarly, the extra-constraints wild card is handled right before renaming
446 too, and is therefore also not supported in a TH type splice. Another reason
447 to forbid extra-constraints wild cards in TH type splices is that a single
448 signature can contain many TH type splices, whereas it mustn't contain more
449 than one extra-constraints wild card. Enforcing would this be hard the way
450 things are currently organised.
451
452 Anonymous wild cards pose no problem, because they start out without names and
453 are given names during renaming. These names are collected right after
454 renaming. The names generated for anonymous wild cards in TH type splices will
455 thus be collected as well.
456
457 For more details about renaming wild cards, see rnLHsTypeWithWildCards.
458
459 Note that partial type signatures are fully supported in TH declaration
460 splices, e.g.:
461
462 [d| foo :: _ => _
463 foo x y = x == y |]
464
465 This is because in this case, the partial type signature can be treated as a
466 whole signature, instead of as an arbitray type.
467
468 -}
469
470 -- | Check that the type splice doesn't contain an extra-constraint wild card.
471 -- See Note [Partial Type Splices]. Named wild cards aren't supported in type
472 -- splices either, but they will be caught during renaming, as they won't be
473 -- in scope.
474 --
475 -- Note that without this check, an error would still be reported, but it
476 -- would tell the user an unexpected wild card was encountered. This message
477 -- is confusing, as it doesn't mention the wild card was unexpected because it
478 -- was an extra-constraints wild card. To avoid confusing, this function
479 -- provides a specific error message for this case.
480 checkValidPartialTypeSplice :: HsDocContext -> LHsType RdrName -> RnM ()
481 checkValidPartialTypeSplice doc ty
482 | (L loc _extraWc : _, _) <- collectWildCards ty
483 = failAt loc $ hang (text "Invalid partial type:") 2 (ppr ty) $$
484 text "An extra-constraints wild card is not allowed in a type splice" $$
485 docOfHsDocContext doc
486 | otherwise
487 = return ()
488
489 ----------------------
490 -- | Rename a splice pattern. See Note [rnSplicePat]
491 rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name)
492 , FreeVars)
493 rnSplicePat splice
494 = rnSpliceGen run_pat_splice pend_pat_splice splice
495 where
496 pend_pat_splice rn_splice
497 = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
498
499 run_pat_splice rn_splice
500 = do { pat <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice
501 ; return (Left (ParPat pat), emptyFVs) }
502 -- Wrap the result of the quasi-quoter in parens so that we don't
503 -- lose the outermost location set by runQuasiQuote (#7918)
504
505 ----------------------
506 rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
507 rnSpliceDecl (SpliceDecl (L loc splice) flg)
508 = rnSpliceGen run_decl_splice pend_decl_splice splice
509 where
510 pend_decl_splice rn_splice
511 = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg)
512
513 run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
514
515 rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
516 -- Declaration splice at the very top level of the module
517 rnTopSpliceDecls splice
518 = do { (rn_splice, fvs) <- setStage (Splice False) $
519 rnSplice splice
520 ; decls <- runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
521 ; return (decls,fvs) }
522 where
523 ppr_decls :: [LHsDecl RdrName] -> SDoc
524 ppr_decls ds = vcat (map ppr ds)
525
526 {-
527 Note [rnSplicePat]
528 ~~~~~~~~~~~~~~~~~~
529 Renaming a pattern splice is a bit tricky, because we need the variables
530 bound in the pattern to be in scope in the RHS of the pattern. This scope
531 management is effectively done by using continuation-passing style in
532 RnPat, through the CpsRn monad. We don't wish to be in that monad here
533 (it would create import cycles and generally conflict with renaming other
534 splices), so we really want to return a (Pat RdrName) -- the result of
535 running the splice -- which can then be further renamed in RnPat, in
536 the CpsRn monad.
537
538 The problem is that if we're renaming a splice within a bracket, we
539 *don't* want to run the splice now. We really do just want to rename
540 it to an HsSplice Name. Of course, then we can't know what variables
541 are bound within the splice, so pattern splices within brackets aren't
542 all that useful.
543
544 In any case, when we're done in rnSplicePat, we'll either have a
545 Pat RdrName (the result of running a top-level splice) or a Pat Name
546 (the renamed nested splice). Thus, the awkward return type of
547 rnSplicePat.
548 -}
549
550 spliceCtxt :: HsSplice RdrName -> SDoc
551 spliceCtxt splice
552 = hang (ptext (sLit "In the") <+> what) 2 (ppr splice)
553 where
554 what = case splice of
555 HsUntypedSplice {} -> ptext (sLit "untyped splice:")
556 HsTypedSplice {} -> ptext (sLit "typed splice:")
557 HsQuasiQuote {} -> ptext (sLit "quasi-quotation:")
558
559 -- | The splice data to be logged
560 data SpliceInfo
561 = SpliceInfo
562 { spliceDescription :: String
563 , spliceSource :: Maybe (LHsExpr Name) -- Nothing <=> top-level decls
564 -- added by addTopDecls
565 , spliceIsDecl :: Bool -- True <=> put the generate code in a file
566 -- when -dth-dec-file is on
567 , spliceGenerated :: SDoc
568 }
569 -- Note that 'spliceSource' is *renamed* but not *typechecked*
570 -- Reason (a) less typechecking crap
571 -- (b) data constructors after type checking have been
572 -- changed to their *wrappers*, and that makes them
573 -- print always fully qualified
574
575 -- | outputs splice information for 2 flags which have different output formats:
576 -- `-ddump-splices` and `-dth-dec-file`
577 traceSplice :: SpliceInfo -> TcM ()
578 traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
579 , spliceGenerated = gen, spliceIsDecl = is_decl })
580 = do { loc <- case mb_src of
581 Nothing -> getSrcSpanM
582 Just (L loc _) -> return loc
583 ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
584
585 ; when is_decl $ -- Raw material for -dth-dec-file
586 do { dflags <- getDynFlags
587 ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
588 (spliceCodeDoc loc) } }
589 where
590 -- `-ddump-splices`
591 spliceDebugDoc :: SrcSpan -> SDoc
592 spliceDebugDoc loc
593 = let code = case mb_src of
594 Nothing -> ending
595 Just e -> nest 2 (ppr e) : ending
596 ending = [ text "======>", nest 2 gen ]
597 in hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
598 2 (sep code)
599
600 -- `-dth-dec-file`
601 spliceCodeDoc :: SrcSpan -> SDoc
602 spliceCodeDoc loc
603 = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
604 , gen ]
605
606 illegalTypedSplice :: SDoc
607 illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets")
608
609 illegalUntypedSplice :: SDoc
610 illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets")
611
612 -- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
613 -- spliceResultDoc expr
614 -- = vcat [ hang (ptext (sLit "In the splice:"))
615 -- 2 (char '$' <> pprParendExpr expr)
616 -- , ptext (sLit "To see what the splice expanded to, use -ddump-splices") ]
617 #endif
618
619 checkThLocalName :: Name -> RnM ()
620 checkThLocalName name
621 | isUnboundName name -- Do not report two errors for
622 = return () -- $(not_in_scope args)
623
624 | otherwise
625 = do { traceRn (text "checkThLocalName" <+> ppr name)
626 ; mb_local_use <- getStageAndBindLevel name
627 ; case mb_local_use of {
628 Nothing -> return () ; -- Not a locally-bound thing
629 Just (top_lvl, bind_lvl, use_stage) ->
630 do { let use_lvl = thLevel use_stage
631 ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
632 ; traceRn (text "checkThLocalName" <+> ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
633 ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
634
635 --------------------------------------
636 checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
637 -> Name -> TcM ()
638 -- We are inside brackets, and (use_lvl > bind_lvl)
639 -- Now we must check whether there's a cross-stage lift to do
640 -- Examples \x -> [| x |]
641 -- [| map |]
642 --
643 -- This code is similar to checkCrossStageLifting in TcExpr, but
644 -- this is only run on *untyped* brackets.
645
646 checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
647 | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets
648 , use_lvl > bind_lvl -- Cross-stage condition
649 = check_cross_stage_lifting top_lvl name ps_var
650 | otherwise
651 = return ()
652
653 check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
654 check_cross_stage_lifting top_lvl name ps_var
655 | isTopLevel top_lvl
656 -- Top-level identifiers in this module,
657 -- (which have External Names)
658 -- are just like the imported case:
659 -- no need for the 'lifting' treatment
660 -- E.g. this is fine:
661 -- f x = x
662 -- g y = [| f 3 |]
663 = when (isExternalName name) (keepAlive name)
664 -- See Note [Keeping things alive for Template Haskell]
665
666 | otherwise
667 = -- Nested identifiers, such as 'x' in
668 -- E.g. \x -> [| h x |]
669 -- We must behave as if the reference to x was
670 -- h $(lift x)
671 -- We use 'x' itself as the SplicePointName, used by
672 -- the desugarer to stitch it all back together.
673 -- If 'x' occurs many times we may get many identical
674 -- bindings of the same SplicePointName, but that doesn't
675 -- matter, although it's a mite untidy.
676 do { traceRn (text "checkCrossStageLifting" <+> ppr name)
677
678 -- Construct the (lift x) expression
679 ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name)
680 pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
681
682 -- Update the pending splices
683 ; ps <- readMutVar ps_var
684 ; writeMutVar ps_var (pend_splice : ps) }
685
686 {-
687 Note [Keeping things alive for Template Haskell]
688 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
689 Consider
690 f x = x+1
691 g y = [| f 3 |]
692
693 Here 'f' is referred to from inside the bracket, which turns into data
694 and mentions only f's *name*, not 'f' itself. So we need some other
695 way to keep 'f' alive, lest it get dropped as dead code. That's what
696 keepAlive does. It puts it in the keep-alive set, which subsequently
697 ensures that 'f' stays as a top level binding.
698
699 This must be done by the renamer, not the type checker (as of old),
700 because the type checker doesn't typecheck the body of untyped
701 brackets (Trac #8540).
702
703 A thing can have a bind_lvl of outerLevel, but have an internal name:
704 foo = [d| op = 3
705 bop = op + 1 |]
706 Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is
707 bound inside a bracket. That is because we don't even even record
708 binding levels for top-level things; the binding levels are in the
709 LocalRdrEnv.
710
711 So the occurrence of 'op' in the rhs of 'bop' looks a bit like a
712 cross-stage thing, but it isn't really. And in fact we never need
713 to do anything here for top-level bound things, so all is fine, if
714 a bit hacky.
715
716 For these chaps (which have Internal Names) we don't want to put
717 them in the keep-alive set.
718
719 Note [Quoting names]
720 ~~~~~~~~~~~~~~~~~~~~
721 A quoted name 'n is a bit like a quoted expression [| n |], except that we
722 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
723 the use-level to account for the brackets, the cases are:
724
725 bind > use Error
726 bind = use+1 OK
727 bind < use
728 Imported things OK
729 Top-level things OK
730 Non-top-level Error
731
732 where 'use' is the binding level of the 'n quote. (So inside the implied
733 bracket the level would be use+1.)
734
735 Examples:
736
737 f 'map -- OK; also for top-level defns of this module
738
739 \x. f 'x -- Not ok (bind = 1, use = 1)
740 -- (whereas \x. f [| x |] might have been ok, by
741 -- cross-stage lifting
742
743 \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)
744
745 [| \x. $(f 'x) |] -- OK (bind = 2, use = 1)
746 -}