RnSplice.hs 31.2 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3
module RnSplice (
4 5 6
        rnTopSpliceDecls,
        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
        rnBracket,
gmainland's avatar
gmainland committed
7
        checkThLocalName
8 9 10
#ifdef GHCI
        , traceSplice, SpliceInfo(..)
#endif
11 12
  ) where

13
#include "HsVersions.h"
14

15 16 17 18
import Name
import NameSet
import HsSyn
import RdrName
gmainland's avatar
gmainland committed
19
import TcRnMonad
20
import Kind
gmainland's avatar
gmainland committed
21

22 23
import RnEnv
import RnSource         ( rnSrcDecls, findSplice )
24
import RnPat            ( rnPat )
25
import BasicTypes       ( TopLevelFlag, isTopLevel )
26 27 28 29 30 31 32 33 34 35 36 37
import Outputable
import Module
import SrcLoc
import DynFlags
import RnTypes          ( rnLHsType )

import Control.Monad    ( unless, when )

import {-# SOURCE #-} RnExpr   ( rnLExpr )

import PrelNames        ( isUnboundName )
import TcEnv            ( checkWellStaged )
38
import THNames          ( liftName )
39 40

#ifdef GHCI
41
import FastString
42 43
import ErrUtils         ( dumpIfSet_dyn_printer )
import TcEnv            ( tcMetaTy )
44
import Hooks
45
import Var              ( Id )
46 47
import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
thomasw's avatar
thomasw committed
48
import RnTypes          ( collectWildCards )
49
import Util
50

gmainland's avatar
gmainland committed
51
import {-# SOURCE #-} TcExpr   ( tcMonoExpr )
52
import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
gmainland's avatar
gmainland committed
53 54
#endif

55 56 57 58 59 60 61 62
{-
************************************************************************
*                                                                      *
        Template Haskell brackets
*                                                                      *
************************************************************************
-}

gmainland's avatar
gmainland committed
63
rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
64 65
rnBracket e br_body
  = addErrCtxt (quotationCtxtDoc br_body) $
66 67 68
    do { -- Check that -XTemplateHaskellQuotes is enabled and available
         thQuotesEnabled <- xoptM Opt_TemplateHaskellQuotes
       ; unless thQuotesEnabled $
69 70
           failWith ( vcat
                      [ text "Syntax error on" <+> ppr e
71 72
                      , text ("Perhaps you intended to use TemplateHaskell"
                              ++ " or TemplateHaskellQuotes") ] )
73 74 75 76

         -- Check for nested brackets
       ; cur_stage <- getStage
       ; case cur_stage of
77 78 79 80 81 82
           { Splice Typed   -> checkTc (isTypedBracket br_body)
                                       illegalUntypedBracket
           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))
                                       illegalTypedBracket
           ; Comp           -> return ()
           ; Brack {}       -> failWithTc illegalBracket
83 84 85 86 87 88
           }

         -- Brackets are desugared to code that mentions the TH package
       ; recordThUse

       ; case isTypedBracket br_body of
89 90 91 92
            True  -> do { traceRn (text "Renaming typed TH bracket")
                        ; (body', fvs_e) <-
                          setStage (Brack cur_stage RnPendingTyped) $
                                   rn_bracket cur_stage br_body
93 94
                        ; return (HsBracket body', fvs_e) }

95 96 97 98 99
            False -> do { traceRn (text "Renaming untyped TH bracket")
                        ; ps_var <- newMutVar []
                        ; (body', fvs_e) <-
                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
                                   rn_bracket cur_stage br_body
100 101 102 103 104 105 106 107 108
                        ; pendings <- readMutVar ps_var
                        ; return (HsRnBracketOut body' pendings, fvs_e) }
       }

rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
rn_bracket outer_stage br@(VarBr flg rdr_name)
  = do { name <- lookupOccRn rdr_name
       ; this_mod <- getModule

109 110
       ; when (flg && nameIsLocalOrFrom this_mod name) $
             -- Type variables can be quoted in TH. See #5721.
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
                    ; case mb_bind_lvl of
                        { Nothing -> return ()      -- Can happen for data constructors,
                                                    -- but nothing needs to be done for them

                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]
                             | isTopLevel top_lvl
                             -> when (isExternalName name) (keepAlive name)
                             | otherwise
                             -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)
                                             (quotedNameStageErr br) }
                        }
                    }
       ; return (VarBr flg name, unitFV name) }

rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
                            ; return (ExpBr e', fvs) }

rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)

rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
                            ; return (TypBr t', fvs) }

rn_bracket _ (DecBrL decls)
  = do { group <- groupDecls decls
       ; gbl_env  <- getGblEnv
       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
                          -- The emptyDUs is so that we just collect uses for this
                          -- group alone in the call to rnSrcDecls below
       ; (tcg_env, group') <- setGblEnv new_gbl_env $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
142
                              rnSrcDecls group
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167

              -- Discard the tcg_env; it contains only extra info about fixity
        ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
                   ppr (duUses (tcg_dus tcg_env))))
        ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
  where
    groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)
    groupDecls decls
      = do { (group, mb_splice) <- findSplice decls
           ; case mb_splice of
           { Nothing -> return group
           ; Just (splice, rest) ->
               do { group' <- groupDecls rest
                  ; let group'' = appendGroups group group'
                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }
                  }
           }}

rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"

rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
                             ; return (TExpBr e', fvs) }

quotationCtxtDoc :: HsBracket RdrName -> SDoc
quotationCtxtDoc br_body
168
  = hang (text "In the Template Haskell quotation")
169 170 171
         2 (ppr br_body)

illegalBracket :: SDoc
172 173 174
illegalBracket =
    text "Template Haskell brackets cannot be nested" <+>
    text "(without intervening splices)"
175

176
illegalTypedBracket :: SDoc
177 178
illegalTypedBracket =
    text "Typed brackets may only appear in typed splices."
179 180

illegalUntypedBracket :: SDoc
181 182
illegalUntypedBracket =
    text "Untyped brackets may only appear in untyped splices."
183 184 185

quotedNameStageErr :: HsBracket RdrName -> SDoc
quotedNameStageErr br
186 187
  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
        , text "must be used at the same stage at which is is bound" ]
188 189

#ifndef GHCI
190 191
rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
rnTopSpliceDecls e = failTH e "Template Haskell top splice"
192

193 194
rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
             -> RnM (HsType Name, FreeVars)
195
rnSpliceType e _ = failTH e "Template Haskell type splice"
gmainland's avatar
gmainland committed
196

197 198
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr e = failTH e "Template Haskell splice"
gmainland's avatar
gmainland committed
199

200
rnSplicePat :: HsSplice RdrName -> RnM (Either (Pat RdrName) (Pat Name), FreeVars)
201
rnSplicePat e = failTH e "Template Haskell pattern splice"
gmainland's avatar
gmainland committed
202

203
rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
204
rnSpliceDecl e = failTH e "Template Haskell declaration splice"
gmainland's avatar
gmainland committed
205
#else
206

Austin Seipp's avatar
Austin Seipp committed
207 208 209
{-
*********************************************************
*                                                      *
210
                Splices
Austin Seipp's avatar
Austin Seipp committed
211 212
*                                                      *
*********************************************************
213

214 215 216
Note [Free variables of typed splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider renaming this:
217 218 219
        f = ...
        h = ...$(thing "f")...

220 221 222 223 224 225 226 227 228
where the splice is a *typed* splice.  The splice can expand into
literally anything, so when we do dependency analysis we must assume
that it might mention 'f'.  So we simply treat all locally-defined
names as mentioned by any splice.  This is terribly brutal, but I
don't see what else to do.  For example, it'll mean that every
locally-defined thing will appear to be used, so no unused-binding
warnings.  But if we miss the dependency, then we might typecheck 'h'
before 'f', and that will crash the type checker because 'f' isn't in
scope.
229 230 231 232 233 234

Currently, I'm not treating a splice as also mentioning every import,
which is a bit inconsistent -- but there are a lot of them.  We might
thereby get some bogus unused-import warnings, but we won't crash the
type checker.  Not very satisfactory really.

235 236 237 238 239 240
Note [Renamer errors]
~~~~~~~~~~~~~~~~~~~~~
It's important to wrap renamer calls in checkNoErrs, because the
renamer does not fail for out of scope variables etc. Instead it
returns a bogus term/type, so that it can report more than one error.
We don't want the type checker to see these bogus unbound variables.
Austin Seipp's avatar
Austin Seipp committed
241
-}
242

243
rnSpliceGen :: (HsSplice Name -> RnM (a, FreeVars))     -- Outside brackets, run splice
244 245 246
            -> (HsSplice Name -> (PendingRnSplice, a))  -- Inside brackets, make it pending
            -> HsSplice RdrName
            -> RnM (a, FreeVars)
247 248
rnSpliceGen run_splice pend_splice splice
  = addErrCtxt (spliceCtxt splice) $ do
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
    { stage <- getStage
    ; case stage of
        Brack pop_stage RnPendingTyped
          -> do { checkTc is_typed_splice illegalUntypedSplice
                ; (splice', fvs) <- setStage pop_stage $
                                    rnSplice splice
                ; let (_pending_splice, result) = pend_splice splice'
                ; return (result, fvs) }

        Brack pop_stage (RnPendingUntyped ps_var)
          -> do { checkTc (not is_typed_splice) illegalTypedSplice
                ; (splice', fvs) <- setStage pop_stage $
                                    rnSplice splice
                ; let (pending_splice, result) = pend_splice splice'
                ; ps <- readMutVar ps_var
                ; writeMutVar ps_var (pending_splice : ps)
                ; return (result, fvs) }

267
        _ ->  do { (splice', fvs1) <- checkNoErrs $
268
                                      setStage (Splice splice_type) $
269
                                      rnSplice splice
270 271 272
                   -- checkNoErrs: don't attempt to run the splice if
                   -- renaming it failed; otherwise we get a cascade of
                   -- errors from e.g. unbound variables
273 274
                 ; (result, fvs2) <- run_splice splice'
                 ; return (result, fvs1 `plusFV` fvs2) } }
275 276
   where
     is_typed_splice = isTypedSplice splice
277 278 279
     splice_type = if is_typed_splice
                   then Typed
                   else Untyped
280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297

------------------
runRnSplice :: UntypedSpliceFlavour
            -> (LHsExpr Id -> TcRn res)
            -> (res -> SDoc)    -- How to pretty-print res
                                -- Usually just ppr, but not for [Decl]
            -> HsSplice Name    -- Always untyped
            -> TcRn res
runRnSplice flavour run_meta ppr_res splice
  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)

       ; let the_expr = case splice' of
                  HsUntypedSplice _ e     ->  e
                  HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
                  HsTypedSplice {}        -> pprPanic "runRnSplice" (ppr splice)

             -- Typecheck the expression
       ; meta_exp_ty   <- tcMetaTy meta_ty_name
298
       ; zonked_q_expr <- tcTopSpliceExpr Untyped $
299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
                          tcMonoExpr the_expr meta_exp_ty

             -- Run the expression
       ; result <- run_meta zonked_q_expr
       ; traceSplice (SpliceInfo { spliceDescription = what
                                 , spliceIsDecl      = is_decl
                                 , spliceSource      = Just the_expr
                                 , spliceGenerated   = ppr_res result })

       ; return result }

  where
    meta_ty_name = case flavour of
                       UntypedExpSplice  -> expQTyConName
                       UntypedPatSplice  -> patQTyConName
                       UntypedTypeSplice -> typeQTyConName
                       UntypedDeclSplice -> decsQTyConName
    what = case flavour of
                  UntypedExpSplice  -> "expression"
                  UntypedPatSplice  -> "pattern"
                  UntypedTypeSplice -> "type"
                  UntypedDeclSplice -> "declarations"
    is_decl = case flavour of
                 UntypedDeclSplice -> True
                 _                 -> False

------------------
makePending :: UntypedSpliceFlavour
            -> HsSplice Name
            -> PendingRnSplice
makePending flavour (HsUntypedSplice n e)
  = PendingRnSplice flavour n e
makePending flavour (HsQuasiQuote n quoter q_span quote)
  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
makePending _ splice@(HsTypedSplice {})
  = pprPanic "makePending" (ppr splice)

------------------
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name
-- Return the expression (quoter "...quote...")
-- which is what we must run in a quasi-quote
mkQuasiQuoteExpr flavour quoter q_span quote
  = L q_span $ HsApp (L q_span $
342 343
                      HsApp (L q_span (HsVar (L q_span quote_selector)))
                            quoterExpr)
344 345
                     quoteExpr
  where
346
    quoterExpr = L q_span $! HsVar $! (L q_span quoter)
347 348 349 350 351 352
    quoteExpr  = L q_span $! HsLit $! HsString "" quote
    quote_selector = case flavour of
                       UntypedExpSplice  -> quoteExpName
                       UntypedPatSplice  -> quotePatName
                       UntypedTypeSplice -> quoteTypeName
                       UntypedDeclSplice -> quoteDecName
353 354

---------------------
355
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
356
-- Not exported...used for all
357 358 359 360 361 362 363 364 365
rnSplice (HsTypedSplice splice_name expr)
  = do  { checkTH expr "Template Haskell typed splice"
        ; loc  <- getSrcSpanM
        ; n' <- newLocalBndrRn (L loc splice_name)
        ; (expr', fvs) <- rnLExpr expr
        ; return (HsTypedSplice n' expr', fvs) }

rnSplice (HsUntypedSplice splice_name expr)
  = do  { checkTH expr "Template Haskell untyped splice"
366
        ; loc  <- getSrcSpanM
367
        ; n' <- newLocalBndrRn (L loc splice_name)
368
        ; (expr', fvs) <- rnLExpr expr
369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
        ; return (HsUntypedSplice n' expr', fvs) }

rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
  = do  { checkTH quoter "Template Haskell quasi-quote"
        ; loc  <- getSrcSpanM
        ; splice_name' <- newLocalBndrRn (L loc splice_name)

          -- Drop the leading "$" from the quoter name, if present
          -- This is old-style syntax, now deprecated
          -- NB: when removing this backward-compat, remove
          --     the matching code in Lexer.x (around line 310)
        ; let occ_str = occNameString (rdrNameOcc quoter)
        ; quoter <- if ASSERT( not (null occ_str) )  -- Lexer ensures this
                       head occ_str /= '$'
                    then return quoter
                    else do { addWarn (deprecatedDollar quoter)
                            ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }

          -- Rename the quoter; akin to the HsVar case of rnExpr
        ; quoter' <- lookupOccRn quoter
        ; this_mod <- getModule
        ; when (nameIsLocalOrFrom this_mod quoter') $
          checkThLocalName quoter'

        ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }

deprecatedDollar :: RdrName -> SDoc
deprecatedDollar quoter
  = hang (ptext (sLit "Deprecated syntax:"))
       2 (ptext (sLit "quasiquotes no longer need a dollar sign:")
          <+> ppr quoter)

401

402
---------------------
403 404 405
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr splice
  = rnSpliceGen run_expr_splice pend_expr_splice splice
gmainland's avatar
gmainland committed
406
  where
407
    pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name)
408 409
    pend_expr_splice rn_splice
        = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice)
410 411

    run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars)
412 413
    run_expr_splice rn_splice
      | isTypedSplice rn_splice   -- Run it later, in the type checker
414
      = do {  -- Ugh!  See Note [Splices] above
415 416
             traceRn (text "rnSpliceExpr: typed expression splice")
           ; lcl_rdr <- getLocalRdrEnv
417 418 419 420
           ; gbl_rdr <- getGlobalRdrEnv
           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
                                                     , isLocalGRE gre]
                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
gmainland's avatar
gmainland committed
421

422
           ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
423 424

      | otherwise  -- Run it here
425 426
      = do { traceRn (text "rnSpliceExpr: untyped expression splice")
           ; rn_expr <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice
427 428
           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
           ; return (HsPar lexpr3, fvs)  }
429 430

----------------------
431 432
rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
             -> RnM (HsType Name, FreeVars)
433
rnSpliceType splice k
434
  = rnSpliceGen run_type_splice pend_type_splice splice
435
  where
436 437
    pend_type_splice rn_splice
       = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
gmainland's avatar
gmainland committed
438

439
    run_type_splice rn_splice
440 441
      = do { traceRn (text "rnSpliceType: untyped type splice")
           ; hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
442
           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
thomasw's avatar
thomasw committed
443 444
                                 ; checkValidPartialTypeSplice doc hs_ty2
                                    -- See Note [Partial Type Splices]
445 446 447 448 449
                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }
                                    -- checkNoErrs: see Note [Renamer errors]
           ; return (HsParTy hs_ty3, fvs) }
              -- Wrap the result of the splice in parens so that we don't
              -- lose the outermost location set by runQuasiQuote (#7918)
thomasw's avatar
thomasw committed
450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
{-
Note [Partial Type Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~

Partial Type Signatures are partially supported in TH type splices: only
anonymous wild cards are allowed.

Normally, named wild cards are collected before renaming a (partial) type
signature. However, TH type splices are run during renaming, i.e. after the
initial traversal, leading to out of scope errors for named wild cards. We
can't just extend the initial traversal to collect the named wild cards in TH
type splices, as we'd need to expand them, which is supposed to happen only
once, during renaming.

Similarly, the extra-constraints wild card is handled right before renaming
too, and is therefore also not supported in a TH type splice. Another reason
to forbid extra-constraints wild cards in TH type splices is that a single
signature can contain many TH type splices, whereas it mustn't contain more
than one extra-constraints wild card. Enforcing would this be hard the way
things are currently organised.

Anonymous wild cards pose no problem, because they start out without names and
are given names during renaming. These names are collected right after
renaming. The names generated for anonymous wild cards in TH type splices will
thus be collected as well.

For more details about renaming wild cards, see rnLHsTypeWithWildCards.

Note that partial type signatures are fully supported in TH declaration
splices, e.g.:

     [d| foo :: _ => _
         foo x y = x == y |]

This is because in this case, the partial type signature can be treated as a
whole signature, instead of as an arbitray type.

-}

-- | Check that the type splice doesn't contain an extra-constraint wild card.
-- See Note [Partial Type Splices]. Named wild cards aren't supported in type
-- splices either, but they will be caught during renaming, as they won't be
-- in scope.
--
-- Note that without this check, an error would still be reported, but it
-- would tell the user an unexpected wild card was encountered. This message
-- is confusing, as it doesn't mention the wild card was unexpected because it
-- was an extra-constraints wild card. To avoid confusing, this function
-- provides a specific error message for this case.
checkValidPartialTypeSplice :: HsDocContext -> LHsType RdrName -> RnM ()
checkValidPartialTypeSplice doc ty
  | (L loc _extraWc : _, _) <- collectWildCards ty
  = failAt loc $ hang (text "Invalid partial type:") 2 (ppr ty) $$
    text "An extra-constraints wild card is not allowed in a type splice" $$
    docOfHsDocContext doc
  | otherwise
  = return ()
507

508 509 510 511 512 513 514 515 516
----------------------
-- | Rename a splice pattern. See Note [rnSplicePat]
rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name)
                                       , FreeVars)
rnSplicePat splice
  = rnSpliceGen run_pat_splice pend_pat_splice splice
  where
    pend_pat_splice rn_splice
      = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
517

518
    run_pat_splice rn_splice
519 520
      = do { traceRn (text "rnSplicePat: untyped pattern splice")
           ; pat <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice
521 522 523
           ; return (Left (ParPat pat), emptyFVs) }
              -- Wrap the result of the quasi-quoter in parens so that we don't
              -- lose the outermost location set by runQuasiQuote (#7918)
524

525 526 527 528 529 530 531
----------------------
rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
rnSpliceDecl (SpliceDecl (L loc splice) flg)
  = rnSpliceGen run_decl_splice pend_decl_splice splice
  where
    pend_decl_splice rn_splice
       = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg)
532

533 534 535 536 537
    run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)

rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
-- Declaration splice at the very top level of the module
rnTopSpliceDecls splice
538
   = do  { (rn_splice, fvs) <- setStage (Splice Untyped) $
539
                               rnSplice splice
540
         ; traceRn (text "rnTopSpliceDecls: untyped declaration splice")
541 542 543 544 545
         ; decls <- runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
         ; return (decls,fvs) }
   where
     ppr_decls :: [LHsDecl RdrName] -> SDoc
     ppr_decls ds = vcat (map ppr ds)
546

Austin Seipp's avatar
Austin Seipp committed
547
{-
548 549 550 551 552 553 554 555 556 557 558 559 560 561
Note [rnSplicePat]
~~~~~~~~~~~~~~~~~~
Renaming a pattern splice is a bit tricky, because we need the variables
bound in the pattern to be in scope in the RHS of the pattern. This scope
management is effectively done by using continuation-passing style in
RnPat, through the CpsRn monad. We don't wish to be in that monad here
(it would create import cycles and generally conflict with renaming other
splices), so we really want to return a (Pat RdrName) -- the result of
running the splice -- which can then be further renamed in RnPat, in
the CpsRn monad.

The problem is that if we're renaming a splice within a bracket, we
*don't* want to run the splice now. We really do just want to rename
it to an HsSplice Name. Of course, then we can't know what variables
562 563 564 565
are bound within the splice. So we accept any unbound variables and
rename them again when the bracket is spliced in.  If a variable is brought
into scope by a pattern splice all is fine.  If it is not then an error is
reported.
566 567 568 569 570

In any case, when we're done in rnSplicePat, we'll either have a
Pat RdrName (the result of running a top-level splice) or a Pat Name
(the renamed nested splice). Thus, the awkward return type of
rnSplicePat.
Austin Seipp's avatar
Austin Seipp committed
571
-}
572

573 574 575 576 577 578 579 580
spliceCtxt :: HsSplice RdrName -> SDoc
spliceCtxt splice
  = hang (ptext (sLit "In the") <+> what) 2 (ppr splice)
  where
    what = case splice of
             HsUntypedSplice {} -> ptext (sLit "untyped splice:")
             HsTypedSplice   {} -> ptext (sLit "typed splice:")
             HsQuasiQuote    {} -> ptext (sLit "quasi-quotation:")
581 582 583 584

-- | The splice data to be logged
data SpliceInfo
  = SpliceInfo
585 586 587 588 589
    { spliceDescription   :: String
    , spliceSource        :: Maybe (LHsExpr Name)  -- Nothing <=> top-level decls
                                                   --        added by addTopDecls
    , spliceIsDecl        :: Bool    -- True <=> put the generate code in a file
                                     --          when -dth-dec-file is on
590 591
    , spliceGenerated     :: SDoc
    }
592 593 594 595 596
        -- Note that 'spliceSource' is *renamed* but not *typechecked*
        -- Reason (a) less typechecking crap
        --        (b) data constructors after type checking have been
        --            changed to their *wrappers*, and that makes them
        --            print always fully qualified
597 598 599 600

-- | outputs splice information for 2 flags which have different output formats:
-- `-ddump-splices` and `-dth-dec-file`
traceSplice :: SpliceInfo -> TcM ()
601 602 603 604 605 606 607 608 609 610 611
traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
                        , spliceGenerated = gen, spliceIsDecl = is_decl })
  = do { loc <- case mb_src of
                   Nothing        -> getSrcSpanM
                   Just (L loc _) -> return loc
       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)

       ; when is_decl $  -- Raw material for -dth-dec-file
         do { dflags <- getDynFlags
            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
                                             (spliceCodeDoc loc) } }
612 613
  where
    -- `-ddump-splices`
614 615 616 617 618 619 620 621
    spliceDebugDoc :: SrcSpan -> SDoc
    spliceDebugDoc loc
      = let code = case mb_src of
                     Nothing -> ending
                     Just e  -> nest 2 (ppr e) : ending
            ending = [ text "======>", nest 2 gen ]
        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
               2 (sep code)
622 623

    -- `-dth-dec-file`
624 625 626 627
    spliceCodeDoc :: SrcSpan -> SDoc
    spliceCodeDoc loc
      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
             , gen ]
gmainland's avatar
gmainland committed
628

629 630 631 632 633 634
illegalTypedSplice :: SDoc
illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets")

illegalUntypedSplice :: SDoc
illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets")

635 636 637 638 639
-- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
-- spliceResultDoc expr
--  = vcat [ hang (ptext (sLit "In the splice:"))
--              2 (char '$' <> pprParendExpr expr)
--        , ptext (sLit "To see what the splice expanded to, use -ddump-splices") ]
gmainland's avatar
gmainland committed
640 641
#endif

642
checkThLocalName :: Name -> RnM ()
Austin Seipp's avatar
Austin Seipp committed
643
checkThLocalName name
644 645 646 647
  | isUnboundName name   -- Do not report two errors for
  = return ()            --   $(not_in_scope args)

  | otherwise
648 649 650 651 652 653
  = do  { traceRn (text "checkThLocalName" <+> ppr name)
        ; mb_local_use <- getStageAndBindLevel name
        ; case mb_local_use of {
             Nothing -> return () ;  -- Not a locally-bound thing
             Just (top_lvl, bind_lvl, use_stage) ->
    do  { let use_lvl = thLevel use_stage
gmainland's avatar
gmainland committed
654
        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
655
        ; traceRn (text "checkThLocalName" <+> ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
656
        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
gmainland's avatar
gmainland committed
657 658

--------------------------------------
659 660
checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
                       -> Name -> TcM ()
gmainland's avatar
gmainland committed
661 662 663 664
-- We are inside brackets, and (use_lvl > bind_lvl)
-- Now we must check whether there's a cross-stage lift to do
-- Examples   \x -> [| x |]
--            [| map |]
665 666 667
--
-- This code is similar to checkCrossStageLifting in TcExpr, but
-- this is only run on *untyped* brackets.
gmainland's avatar
gmainland committed
668

669 670 671 672 673 674 675 676 677
checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets
  , use_lvl > bind_lvl                               -- Cross-stage condition
  = check_cross_stage_lifting top_lvl name ps_var
  | otherwise
  = return ()

check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
check_cross_stage_lifting top_lvl name ps_var
678 679
  | isTopLevel top_lvl
        -- Top-level identifiers in this module,
gmainland's avatar
gmainland committed
680 681 682 683 684 685
        -- (which have External Names)
        -- are just like the imported case:
        -- no need for the 'lifting' treatment
        -- E.g.  this is fine:
        --   f x = x
        --   g y = [| f 3 |]
686 687 688
  = when (isExternalName name) (keepAlive name)
    -- See Note [Keeping things alive for Template Haskell]

gmainland's avatar
gmainland committed
689 690 691 692 693
  | otherwise
  =     -- Nested identifiers, such as 'x' in
        -- E.g. \x -> [| h x |]
        -- We must behave as if the reference to x was
        --      h $(lift x)
694
        -- We use 'x' itself as the SplicePointName, used by
gmainland's avatar
gmainland committed
695 696
        -- the desugarer to stitch it all back together.
        -- If 'x' occurs many times we may get many identical
697
        -- bindings of the same SplicePointName, but that doesn't
gmainland's avatar
gmainland committed
698 699
        -- matter, although it's a mite untidy.
    do  { traceRn (text "checkCrossStageLifting" <+> ppr name)
700 701 702 703 704 705

          -- Construct the (lift x) expression
        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)
              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr

          -- Update the pending splices
gmainland's avatar
gmainland committed
706
        ; ps <- readMutVar ps_var
707
        ; writeMutVar ps_var (pend_splice : ps) }
708

Austin Seipp's avatar
Austin Seipp committed
709
{-
710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768
Note [Keeping things alive for Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  f x = x+1
  g y = [| f 3 |]

Here 'f' is referred to from inside the bracket, which turns into data
and mentions only f's *name*, not 'f' itself. So we need some other
way to keep 'f' alive, lest it get dropped as dead code.  That's what
keepAlive does. It puts it in the keep-alive set, which subsequently
ensures that 'f' stays as a top level binding.

This must be done by the renamer, not the type checker (as of old),
because the type checker doesn't typecheck the body of untyped
brackets (Trac #8540).

A thing can have a bind_lvl of outerLevel, but have an internal name:
   foo = [d| op = 3
             bop = op + 1 |]
Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is
bound inside a bracket.  That is because we don't even even record
binding levels for top-level things; the binding levels are in the
LocalRdrEnv.

So the occurrence of 'op' in the rhs of 'bop' looks a bit like a
cross-stage thing, but it isn't really.  And in fact we never need
to do anything here for top-level bound things, so all is fine, if
a bit hacky.

For these chaps (which have Internal Names) we don't want to put
them in the keep-alive set.

Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
A quoted name 'n is a bit like a quoted expression [| n |], except that we
have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing
the use-level to account for the brackets, the cases are:

        bind > use                      Error
        bind = use+1                    OK
        bind < use
                Imported things         OK
                Top-level things        OK
                Non-top-level           Error

where 'use' is the binding level of the 'n quote. (So inside the implied
bracket the level would be use+1.)

Examples:

  f 'map        -- OK; also for top-level defns of this module

  \x. f 'x      -- Not ok (bind = 1, use = 1)
                -- (whereas \x. f [| x |] might have been ok, by
                --                               cross-stage lifting

  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)

  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)
Austin Seipp's avatar
Austin Seipp committed
769
-}