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