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