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