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