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