compiler/typecheck/TcSplice.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcSplice: Template Haskell splices
   7
   8 \begin{code}
   9 {-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
  17                  runQuasiQuoteExpr, runQuasiQuotePat ) where
  18
  19 #include "HsVersions.h"
  20
  21 import HscMain
  22 import TcRnDriver
  23         -- These imports are the reason that TcSplice
  24         -- is very high up the module hierarchy
  25
  26 import HsSyn
  27 import Convert
  28 import RnExpr
  29 import RnEnv
  30 import RdrName
  31 import RnTypes
  32 import TcExpr
  33 import TcHsSyn
  34 import TcSimplify
  35 import TcUnify
  36 import TcType
  37 import TcEnv
  38 import TcMType
  39 import TcHsType
  40 import TcIface
  41 import TypeRep
  42 import Name
  43 import NameEnv
  44 import HscTypes
  45 import OccName
  46 import Var
  47 import Module
  48 import TcRnMonad
  49 import Class
  50 import TyCon
  51 import DataCon
  52 import Id
  53 import IdInfo
  54 import TysWiredIn
  55 import DsMeta
  56 import DsExpr
  57 import DsMonad hiding (Splice)
  58 import ErrUtils
  59 import SrcLoc
  60 import Outputable
  61 import Unique
  62 import Maybe
  63 import BasicTypes
  64 import Panic
  65 import FastString
  66 import Exception
  67
  68 import qualified Language.Haskell.TH as TH
  69 -- THSyntax gives access to internal functions and data types
  70 import qualified Language.Haskell.TH.Syntax as TH
  71
  72 import GHC.Exts         ( unsafeCoerce#, Int#, Int(..) )
  73 import System.IO.Error
  74 \end{code}
  75
  76 Note [Template Haskell levels]
  77 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  78 * Imported things are impLevel (= 0)
  79
  80 * In GHCi, variables bound by a previous command are treated
  81   as impLevel, because we have bytecode for them.
  82
  83 * Variables are bound at the "current level"
  84
  85 * The current level starts off at topLevel (= 1)
  86
  87 * The level is decremented by splicing $(..)
  88                incremented by brackets [| |]
  89                incremented by name-quoting 'f
  90
  91 When a variable is used, we compare
  92         bind:  binding level, and
  93         use:   current level at usage site
  94
  95   Generally
  96         bind > use      Always error (bound later than used)
  97                         [| \x -> $(f x) |]
  98
  99         bind = use      Always OK (bound same stage as used)
 100                         [| \x -> $(f [| x |]) |]
 101
 102         bind < use      Inside brackets, it depends
 103                         Inside splice, OK
 104                         Inside neither, OK
 105
 106   For (bind < use) inside brackets, there are three cases:
 107     - Imported things   OK      f = [| map |]
 108     - Top-level things  OK      g = [| f |]
 109     - Non-top-level     Only if there is a liftable instance
 110                                 h = \(x:Int) -> [| x |]
 111
 112 See Note [What is a top-level Id?]
 113
 114 Note [Quoting names]
 115 ~~~~~~~~~~~~~~~~~~~~
 116 A quoted name 'n is a bit like a quoted expression [| n |], except that we
 117 have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing
 118 the use-level to account for the brackets, the cases are:
 119
 120         bind > use                      Error
 121         bind = use                      OK
 122         bind < use
 123                 Imported things         OK
 124                 Top-level things        OK
 125                 Non-top-level           Error
 126
 127 See Note [What is a top-level Id?] in TcEnv.  Examples:
 128
 129   f 'map        -- OK; also for top-level defns of this module
 130
 131   \x. f 'x      -- Not ok (whereas \x. f [| x |] might have been ok, by
 132                 --                               cross-stage lifting
 133
 134   \y. [| \x. $(f 'y) |] -- Not ok (same reason)
 135
 136   [| \x. $(f 'x) |]     -- OK
 137
 138
 139 Note [What is a top-level Id?]
 140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 141 In the level-control criteria above, we need to know what a "top level Id" is.
 142 There are three kinds:
 143   * Imported from another module                (GlobalId, ExternalName)
 144   * Bound at the top level of this module       (ExternalName)
 145   * In GHCi, bound by a previous stmt           (GlobalId)
 146 It's strange that there is no one criterion tht picks out all three, but that's
 147 how it is right now.  (The obvious thing is to give an ExternalName to GHCi Ids
 148 bound in an earlier Stmt, but what module would you choose?  See
 149 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
 150
 151 The predicate we use is TcEnv.thTopLevelId.
 152
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection{Main interface + stubs for the non-GHCI case
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 \begin{code}
 161 tcBracket     :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 162 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 163 tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
 164 kcSpliceType  :: HsSplice Name -> TcM (HsType Name, TcKind)
 165         -- None of these functions add constraints to the LIE
 166
 167 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
 168 runQuasiQuotePat  :: HsQuasiQuote Name -> TcM (LPat RdrName)
 169
 170 #ifndef GHCI
 171 tcBracket     x _ = pprPanic "Cant do tcBracket without GHCi"     (ppr x)
 172 tcSpliceExpr  e   = pprPanic "Cant do tcSpliceExpr without GHCi"  (ppr e)
 173 tcSpliceDecls x   = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
 174 kcSpliceType  x   = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
 175
 176 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
 177 runQuasiQuotePat  q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
 178 #else
 179 \end{code}
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Quoting an expression}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 Note [Handling brackets]
 188 ~~~~~~~~~~~~~~~~~~~~~~~~
 189 Source:         f = [| Just $(g 3) |]
 190   The [| |] part is a HsBracket
 191
 192 Typechecked:    f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
 193   The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
 194   The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
 195
 196 Desugared:      f = do { s7 <- g Int 3
 197                        ; return (ConE "Data.Maybe.Just" s7) }
 198
 199 \begin{code}
 200 tcBracket brack res_ty = do
 201    level <- getStage
 202    case bracketOK level of {
 203         Nothing         -> failWithTc (illegalBracket level) ;
 204         Just next_level -> do
 205
 206         -- Typecheck expr to make sure it is valid,
 207         -- but throw away the results.  We'll type check
 208         -- it again when we actually use it.
 209     recordThUse
 210     pending_splices <- newMutVar []
 211     lie_var <- getLIEVar
 212
 213     (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
 214                                (getLIE (tc_bracket next_level brack))
 215     tcSimplifyBracket lie
 216
 217         -- Make the expected type have the right shape
 218     boxyUnify meta_ty res_ty
 219
 220         -- Return the original expression, not the type-decorated one
 221     pendings <- readMutVar pending_splices
 222     return (noLoc (HsBracketOut brack pendings))
 223     }
 224
 225 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
 226 tc_bracket use_lvl (VarBr name)         -- Note [Quoting names]
 227   = do  { thing <- tcLookup name
 228         ; case thing of
 229             AGlobal _ -> return ()
 230             ATcId { tct_level = bind_lvl, tct_id = id }
 231                 | thTopLevelId id       -- C.f thTopLevelId case of
 232                 -> keepAliveTc id       --     TcExpr.thBrackId
 233                 | otherwise
 234                 -> do { checkTc (use_lvl == bind_lvl)
 235                                 (quotedNameStageErr name) }
 236             _ -> pprPanic "th_bracket" (ppr name)
 237
 238         ; tcMetaTy nameTyConName        -- Result type is Var (not Q-monadic)
 239         }
 240
 241 tc_bracket _ (ExpBr expr)
 242   = do  { any_ty <- newFlexiTyVarTy liftedTypeKind
 243         ; tcMonoExpr expr any_ty
 244         ; tcMetaTy expQTyConName }
 245         -- Result type is Expr (= Q Exp)
 246
 247 tc_bracket _ (TypBr typ)
 248   = do  { tcHsSigType ExprSigCtxt typ
 249         ; tcMetaTy typeQTyConName }
 250         -- Result type is Type (= Q Typ)
 251
 252 tc_bracket _ (DecBr decls)
 253   = do  {  tcTopSrcDecls emptyModDetails decls
 254         -- Typecheck the declarations, dicarding the result
 255         -- We'll get all that stuff later, when we splice it in
 256
 257         ; decl_ty <- tcMetaTy decTyConName
 258         ; q_ty    <- tcMetaTy qTyConName
 259         ; return (mkAppTy q_ty (mkListTy decl_ty))
 260         -- Result type is Q [Dec]
 261     }
 262
 263 tc_bracket _ (PatBr _)
 264   = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
 265
 266 quotedNameStageErr :: Name -> SDoc
 267 quotedNameStageErr v
 268   = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
 269         , ptext (sLit "must be used at the same stage at which is is bound")]
 270 \end{code}
 271
 272
 273 %************************************************************************
 274 %*                                                                      *
 275 \subsection{Splicing an expression}
 276 %*                                                                      *
 277 %************************************************************************
 278
 279 \begin{code}
 280 tcSpliceExpr (HsSplice name expr) res_ty
 281   = setSrcSpan (getLoc expr)    $ do
 282     level <- getStage
 283     case spliceOK level of {
 284         Nothing         -> failWithTc (illegalSplice level) ;
 285         Just next_level ->
 286
 287      case level of {
 288         Comp                   -> do { e <- tcTopSplice expr res_ty
 289                                      ; return (unLoc e) } ;
 290         Brack _ ps_var lie_var -> do
 291
 292         -- A splice inside brackets
 293         -- NB: ignore res_ty, apart from zapping it to a mono-type
 294         -- e.g.   [| reverse $(h 4) |]
 295         -- Here (h 4) :: Q Exp
 296         -- but $(h 4) :: forall a.a     i.e. anything!
 297
 298       unBox res_ty
 299       meta_exp_ty <- tcMetaTy expQTyConName
 300       expr' <- setStage (Splice next_level) (
 301                  setLIEVar lie_var    $
 302                  tcMonoExpr expr meta_exp_ty
 303                )
 304
 305         -- Write the pending splice into the bucket
 306       ps <- readMutVar ps_var
 307       writeMutVar ps_var ((name,expr') : ps)
 308
 309       return (panic "tcSpliceExpr")     -- The returned expression is ignored
 310
 311      ; Splice {} -> panic "tcSpliceExpr Splice"
 312      }}
 313
 314 -- tcTopSplice used to have this:
 315 -- Note that we do not decrement the level (to -1) before
 316 -- typechecking the expression.  For example:
 317 --      f x = $( ...$(g 3) ... )
 318 -- The recursive call to tcMonoExpr will simply expand the
 319 -- inner escape before dealing with the outer one
 320
 321 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
 322 tcTopSplice expr res_ty = do
 323     meta_exp_ty <- tcMetaTy expQTyConName
 324
 325         -- Typecheck the expression
 326     zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
 327
 328         -- Run the expression
 329     traceTc (text "About to run" <+> ppr zonked_q_expr)
 330     expr2 <- runMetaE convertToHsExpr zonked_q_expr
 331
 332     traceTc (text "Got result" <+> ppr expr2)
 333
 334     showSplice "expression"
 335                zonked_q_expr (ppr expr2)
 336
 337         -- Rename it, but bale out if there are errors
 338         -- otherwise the type checker just gives more spurious errors
 339     (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
 340
 341     tcMonoExpr exp3 res_ty
 342
 343
 344 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
 345 -- Type check an expression that is the body of a top-level splice
 346 --   (the caller will compile and run it)
 347 tcTopSpliceExpr expr meta_ty
 348   = checkNoErrs $       -- checkNoErrs: must not try to run the thing
 349                         --              if the type checker fails!
 350
 351     setStage topSpliceStage $ do
 352
 353
 354     do  { recordThUse   -- Record that TH is used (for pkg depdendency)
 355
 356         -- Typecheck the expression
 357         ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
 358
 359         -- Solve the constraints
 360         ; const_binds <- tcSimplifyTop lie
 361
 362         -- And zonk it
 363         ; zonkTopLExpr (mkHsDictLet const_binds expr') }
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369         Quasi-quoting
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 Note [Quasi-quote overview]
 374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 375 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
 376 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
 377 Workshop 2007).
 378
 379 Briefly, one writes
 380         [:p| stuff |]
 381 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
 382 type should be Language.Haskell.TH.Quote.QuasiQuoter.  'p' must be
 383 defined in another module, because we are going to run it here.  It's
 384 a bit like a TH splice:
 385         $(p "stuff")
 386
 387 However, you can do this in patterns as well as terms.  Becuase of this,
 388 the splice is run by the *renamer* rather than the type checker.
 389
 390 \begin{code}
 391 runQuasiQuote :: Outputable hs_syn
 392               => HsQuasiQuote Name      -- Contains term of type QuasiQuoter, and the String
 393               -> Name                   -- Of type QuasiQuoter -> String -> Q th_syn
 394               -> String                 -- Documentation string only
 395               -> Name                   -- Name of th_syn type
 396               -> (SrcSpan -> th_syn -> Either Message hs_syn)
 397               -> TcM hs_syn
 398 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
 399   = do  { -- Check that the quoter is not locally defined, otherwise the TH
 400           -- machinery will not be able to run the quasiquote.
 401         ; this_mod <- getModule
 402         ; let is_local = case nameModule_maybe quoter of
 403                            Just mod | mod == this_mod -> True
 404                                     | otherwise       -> False
 405                            Nothing -> True
 406         ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
 407         ; checkTc (not is_local) (quoteStageError quoter)
 408
 409           -- Build the expression
 410         ; let quoterExpr = L q_span $! HsVar $! quoter
 411         ; let quoteExpr = L q_span $! HsLit $! HsString quote
 412         ; let expr = L q_span $
 413                      HsApp (L q_span $
 414                             HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
 415         ; recordThUse
 416         ; meta_exp_ty <- tcMetaTy meta_ty
 417
 418         -- Typecheck the expression
 419         ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
 420
 421         -- Run the expression
 422         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 423         ; result <- runMeta convert zonked_q_expr
 424         ; traceTc (text "Got result" <+> ppr result)
 425         ; showSplice desc zonked_q_expr (ppr result)
 426         ; return result
 427         }
 428
 429 runQuasiQuoteExpr quasiquote
 430     = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
 431
 432 runQuasiQuotePat quasiquote
 433     = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
 434
 435 quoteStageError :: Name -> SDoc
 436 quoteStageError quoter
 437   = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
 438          nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
 439 \end{code}
 440
 441
 442 %************************************************************************
 443 %*                                                                      *
 444                 Splicing a type
 445 %*                                                                      *
 446 %************************************************************************
 447
 448 Very like splicing an expression, but we don't yet share code.
 449
 450 \begin{code}
 451 kcSpliceType (HsSplice name hs_expr)
 452   = setSrcSpan (getLoc hs_expr) $ do
 453         { level <- getStage
 454         ; case spliceOK level of {
 455                 Nothing         -> failWithTc (illegalSplice level) ;
 456                 Just next_level -> do
 457
 458         { case level of {
 459                 Comp                   -> do { (t,k) <- kcTopSpliceType hs_expr
 460                                              ; return (unLoc t, k) } ;
 461                 Brack _ ps_var lie_var -> do
 462
 463         {       -- A splice inside brackets
 464         ; meta_ty <- tcMetaTy typeQTyConName
 465         ; expr' <- setStage (Splice next_level) $
 466                    setLIEVar lie_var            $
 467                    tcMonoExpr hs_expr meta_ty
 468
 469                 -- Write the pending splice into the bucket
 470         ; ps <- readMutVar ps_var
 471         ; writeMutVar ps_var ((name,expr') : ps)
 472
 473         -- e.g.   [| Int -> $(h 4) |]
 474         -- Here (h 4) :: Q Type
 475         -- but $(h 4) :: forall a.a     i.e. any kind
 476         ; kind <- newKindVar
 477         ; return (panic "kcSpliceType", kind)   -- The returned type is ignored
 478     }
 479         ; Splice {} -> panic "kcSpliceType Splice"
 480     }}}}
 481
 482 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
 483 kcTopSpliceType expr
 484   = do  { meta_ty <- tcMetaTy typeQTyConName
 485
 486         -- Typecheck the expression
 487         ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
 488
 489         -- Run the expression
 490         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 491         ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
 492
 493         ; traceTc (text "Got result" <+> ppr hs_ty2)
 494
 495         ; showSplice "type" zonked_q_expr (ppr hs_ty2)
 496
 497         -- Rename it, but bale out if there are errors
 498         -- otherwise the type checker just gives more spurious errors
 499         ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
 500         ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
 501
 502         ; kcHsType hs_ty3 }
 503 \end{code}
 504
 505 %************************************************************************
 506 %*                                                                      *
 507 \subsection{Splicing an expression}
 508 %*                                                                      *
 509 %************************************************************************
 510
 511 \begin{code}
 512 -- Always at top level
 513 -- Type sig at top of file:
 514 --      tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 515 tcSpliceDecls expr
 516   = do  { meta_dec_ty <- tcMetaTy decTyConName
 517         ; meta_q_ty <- tcMetaTy qTyConName
 518         ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
 519         ; zonked_q_expr <- tcTopSpliceExpr expr list_q
 520
 521                 -- Run the expression
 522         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 523         ; decls <- runMetaD convertToHsDecls zonked_q_expr
 524
 525         ; traceTc (text "Got result" <+> vcat (map ppr decls))
 526         ; showSplice "declarations"
 527                      zonked_q_expr
 528                      (ppr (getLoc expr) $$ (vcat (map ppr decls)))
 529         ; return decls }
 530 \end{code}
 531
 532
 533 %************************************************************************
 534 %*                                                                      *
 535 \subsection{Running an expression}
 536 %*                                                                      *
 537 %************************************************************************
 538
 539 \begin{code}
 540 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
 541          -> LHsExpr Id          -- Of type (Q Exp)
 542          -> TcM (LHsExpr RdrName)
 543 runMetaE  = runMeta
 544
 545 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
 546          -> LHsExpr Id          -- Of type (Q Pat)
 547          -> TcM (Pat RdrName)
 548 runMetaP  = runMeta
 549
 550 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
 551          -> LHsExpr Id          -- Of type (Q Type)
 552          -> TcM (LHsType RdrName)
 553 runMetaT = runMeta
 554
 555 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
 556          -> LHsExpr Id          -- Of type Q [Dec]
 557          -> TcM [LHsDecl RdrName]
 558 runMetaD = runMeta
 559
 560 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
 561         -> LHsExpr Id           -- Of type X
 562         -> TcM hs_syn           -- Of type t
 563 runMeta convert expr
 564   = do  {       -- Desugar
 565           ds_expr <- initDsTc (dsLExpr expr)
 566         -- Compile and link it; might fail if linking fails
 567         ; hsc_env <- getTopEnv
 568         ; src_span <- getSrcSpanM
 569         ; either_hval <- tryM $ liftIO $
 570                          HscMain.compileExpr hsc_env src_span ds_expr
 571         ; case either_hval of {
 572             Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
 573             Right hval -> do
 574
 575         {       -- Coerce it to Q t, and run it
 576
 577                 -- Running might fail if it throws an exception of any kind (hence tryAllM)
 578                 -- including, say, a pattern-match exception in the code we are running
 579                 --
 580                 -- We also do the TH -> HS syntax conversion inside the same
 581                 -- exception-cacthing thing so that if there are any lurking
 582                 -- exceptions in the data structure returned by hval, we'll
 583                 -- encounter them inside the try
 584                 --
 585                 -- See Note [Exceptions in TH]
 586           let expr_span = getLoc expr
 587         ; either_tval <- tryAllM $
 588                          setSrcSpan expr_span $ -- Set the span so that qLocation can
 589                                                 -- see where this splice is
 590              do { th_syn <- TH.runQ (unsafeCoerce# hval)
 591                 ; case convert expr_span th_syn of
 592                     Left err     -> failWithTc err
 593                     Right hs_syn -> return hs_syn }
 594
 595         ; case either_tval of
 596             Right v -> return v
 597             Left se ->
 598                     case fromException se of
 599                     Just (ErrorCall "IOEnv failure") ->
 600                         failM -- Error already in Tc monad
 601                     _ ->
 602                         case fromException se of
 603                         Just ioe
 604                          | isUserError ioe &&
 605                            (ioeGetErrorString ioe == "IOEnv failure") ->
 606                             failM -- Error already in Tc monad
 607                         _ -> failWithTc (mk_msg "run" se)       -- Exception
 608         }}}
 609   where
 610     mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
 611                          nest 2 (text (Panic.showException exn)),
 612                          nest 2 (text "Code:" <+> ppr expr)]
 613 \end{code}
 614
 615 Note [Exceptions in TH]
 616 ~~~~~~~~~~~~~~~~~~~~~~~
 617 Supppose we have something like this
 618         $( f 4 )
 619 where
 620         f :: Int -> Q [Dec]
 621         f n | n>3       = fail "Too many declarations"
 622             | otherwise = ...
 623
 624 The 'fail' is a user-generated failure, and should be displayed as a
 625 perfectly ordinary compiler error message, not a panic or anything
 626 like that.  Here's how it's processed:
 627
 628   * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
 629     effectively transforms (fail s) to
 630         qReport True s >> fail
 631     where 'qReport' comes from the Quasi class and fail from its monad
 632     superclass.
 633
 634   * The TcM monad is an instance of Quasi (see TcSplice), and it implements
 635     (qReport True s) by using addErr to add an error message to the bag of errors.
 636     The 'fail' in TcM raises a UserError, with the uninteresting string
 637         "IOEnv failure"
 638
 639   * So, when running a splice, we catch all exceptions; then for
 640         - a UserError "IOEnv failure", we assume the error is already
 641                 in the error-bag (above)
 642         - other errors, we add an error to the bag
 643     and then fail
 644
 645
 646 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
 647
 648 \begin{code}
 649 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
 650   qNewName s = do { u <- newUnique
 651                   ; let i = getKey u
 652                   ; return (TH.mkNameU s i) }
 653
 654   qReport True msg  = addErr (text msg)
 655   qReport False msg = addReport (text msg)
 656
 657   qLocation = do { m <- getModule
 658                  ; l <- getSrcSpanM
 659                  ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
 660                                   , TH.loc_module   = moduleNameString (moduleName m)
 661                                   , TH.loc_package  = packageIdString (modulePackageId m)
 662                                   , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
 663                                   , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
 664
 665   qReify v = reify v
 666
 667         -- For qRecover, discard error messages if
 668         -- the recovery action is chosen.  Otherwise
 669         -- we'll only fail higher up.  c.f. tryTcLIE_
 670   qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
 671                              ; case mb_res of
 672                                  Just val -> do { addMessages msgs      -- There might be warnings
 673                                                 ; return val }
 674                                  Nothing  -> recover                    -- Discard all msgs
 675                           }
 676
 677   qRunIO io = liftIO io
 678 \end{code}
 679
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection{Errors and contexts}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 \begin{code}
 688 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
 689 showSplice what before after = do
 690     loc <- getSrcSpanM
 691     traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
 692                        nest 2 (sep [nest 2 (ppr before),
 693                                     text "======>",
 694                                     nest 2 after])])
 695
 696 illegalBracket :: ThStage -> SDoc
 697 illegalBracket level
 698   = ptext (sLit "Illegal bracket at level") <+> ppr level
 699
 700 illegalSplice :: ThStage -> SDoc
 701 illegalSplice level
 702   = ptext (sLit "Illegal splice at level") <+> ppr level
 703
 704 #endif  /* GHCI */
 705 \end{code}
 706
 707
 708 %************************************************************************
 709 %*                                                                      *
 710                         Reification
 711 %*                                                                      *
 712 %************************************************************************
 713
 714
 715 \begin{code}
 716 reify :: TH.Name -> TcM TH.Info
 717 reify th_name
 718   = do  { name <- lookupThName th_name
 719         ; thing <- tcLookupTh name
 720                 -- ToDo: this tcLookup could fail, which would give a
 721                 --       rather unhelpful error message
 722         ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
 723         ; reifyThing thing
 724     }
 725   where
 726     ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
 727     ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
 728     ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
 729     ppr_ns _ = panic "reify/ppr_ns"
 730
 731 lookupThName :: TH.Name -> TcM Name
 732 lookupThName th_name@(TH.Name occ flavour)
 733   =  do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour
 734                                | gns <- guessed_nss]
 735         ; case catMaybes mb_ns of
 736             []    -> failWithTc (notInScope th_name)
 737             (n:_) -> return n } -- Pick the first that works
 738                                 -- E.g. reify (mkName "A") will pick the class A
 739                                 --      in preference to the data constructor A
 740   where
 741     lookup rdr_name
 742         = do {  -- Repeat much of lookupOccRn, becase we want
 743                 -- to report errors in a TH-relevant way
 744              ; rdr_env <- getLocalRdrEnv
 745              ; case lookupLocalRdrEnv rdr_env rdr_name of
 746                  Just name -> return (Just name)
 747                  Nothing | not (isSrcRdrName rdr_name)  -- Exact, Orig
 748                          -> do { name <- lookupImportedName rdr_name
 749                                ; return (Just name) }
 750                          | otherwise                    -- Unqual, Qual
 751                          -> lookupSrcOcc_maybe rdr_name }
 752
 753         -- guessed_ns are the name spaces guessed from looking at the TH name
 754     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 755                 | otherwise                       = [OccName.varName, OccName.tvName]
 756     occ_str = TH.occString occ
 757
 758 tcLookupTh :: Name -> TcM TcTyThing
 759 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
 760 -- it gives a reify-related error message on failure, whereas in the normal
 761 -- tcLookup, failure is a bug.
 762 tcLookupTh name
 763   = do  { (gbl_env, lcl_env) <- getEnvs
 764         ; case lookupNameEnv (tcl_env lcl_env) name of {
 765                 Just thing -> return thing;
 766                 Nothing    -> do
 767         { if nameIsLocalOrFrom (tcg_mod gbl_env) name
 768           then  -- It's defined in this module
 769               case lookupNameEnv (tcg_type_env gbl_env) name of
 770                 Just thing -> return (AGlobal thing)
 771                 Nothing    -> failWithTc (notInEnv name)
 772
 773           else do               -- It's imported
 774         { (eps,hpt) <- getEpsAndHpt
 775         ; dflags <- getDOpts
 776         ; case lookupType dflags hpt (eps_PTE eps) name of
 777             Just thing -> return (AGlobal thing)
 778             Nothing    -> do { thing <- tcImportDecl name
 779                              ; return (AGlobal thing) }
 780                 -- Imported names should always be findable;
 781                 -- if not, we fail hard in tcImportDecl
 782     }}}}
 783
 784 notInScope :: TH.Name -> SDoc
 785 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
 786                      ptext (sLit "is not in scope at a reify")
 787         -- Ugh! Rather an indirect way to display the name
 788
 789 notInEnv :: Name -> SDoc
 790 notInEnv name = quotes (ppr name) <+>
 791                      ptext (sLit "is not in the type environment at a reify")
 792
 793 ------------------------------
 794 reifyThing :: TcTyThing -> TcM TH.Info
 795 -- The only reason this is monadic is for error reporting,
 796 -- which in turn is mainly for the case when TH can't express
 797 -- some random GHC extension
 798
 799 reifyThing (AGlobal (AnId id))
 800   = do  { ty <- reifyType (idType id)
 801         ; fix <- reifyFixity (idName id)
 802         ; let v = reifyName id
 803         ; case globalIdDetails id of
 804             ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
 805             _                -> return (TH.VarI     v ty Nothing fix)
 806     }
 807
 808 reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
 809 reifyThing (AGlobal (AClass cls)) = reifyClass cls
 810 reifyThing (AGlobal (ADataCon dc))
 811   = do  { let name = dataConName dc
 812         ; ty <- reifyType (idType (dataConWrapId dc))
 813         ; fix <- reifyFixity name
 814         ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
 815
 816 reifyThing (ATcId {tct_id = id, tct_type = ty})
 817   = do  { ty1 <- zonkTcType ty  -- Make use of all the info we have, even
 818                                 -- though it may be incomplete
 819         ; ty2 <- reifyType ty1
 820         ; fix <- reifyFixity (idName id)
 821         ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
 822
 823 reifyThing (ATyVar tv ty)
 824   = do  { ty1 <- zonkTcType ty
 825         ; ty2 <- reifyType ty1
 826         ; return (TH.TyVarI (reifyName tv) ty2) }
 827
 828 reifyThing (AThing {}) = panic "reifyThing AThing"
 829
 830 ------------------------------
 831 reifyTyCon :: TyCon -> TcM TH.Info
 832 reifyTyCon tc
 833   | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2               False)
 834   | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
 835   | isSynTyCon tc
 836   = do { let (tvs, rhs) = synTyConDefn tc
 837        ; rhs' <- reifyType rhs
 838        ; return (TH.TyConI $
 839                    TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 840
 841 reifyTyCon tc
 842   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
 843         ; let tvs = tyConTyVars tc
 844         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
 845         ; let name = reifyName tc
 846               r_tvs  = reifyTyVars tvs
 847               deriv = []        -- Don't know about deriving
 848               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
 849                    | otherwise     = TH.DataD    cxt name r_tvs cons      deriv
 850         ; return (TH.TyConI decl) }
 851
 852 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
 853 reifyDataCon tys dc
 854   | isVanillaDataCon dc
 855   = do  { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
 856         ; let stricts = map reifyStrict (dataConStrictMarks dc)
 857               fields  = dataConFieldLabels dc
 858               name    = reifyName dc
 859               [a1,a2] = arg_tys
 860               [s1,s2] = stricts
 861         ; ASSERT( length arg_tys == length stricts )
 862           if not (null fields) then
 863              return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
 864           else
 865           if dataConIsInfix dc then
 866              ASSERT( length arg_tys == 2 )
 867              return (TH.InfixC (s1,a1) name (s2,a2))
 868           else
 869              return (TH.NormalC name (stricts `zip` arg_tys)) }
 870   | otherwise
 871   = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
 872                 <+> quotes (ppr dc))
 873
 874 ------------------------------
 875 reifyClass :: Class -> TcM TH.Info
 876 reifyClass cls
 877   = do  { cxt <- reifyCxt theta
 878         ; ops <- mapM reify_op op_stuff
 879         ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
 880   where
 881     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
 882     fds' = map reifyFunDep fds
 883     reify_op (op, _) = do { ty <- reifyType (idType op)
 884                           ; return (TH.SigD (reifyName op) ty) }
 885
 886 ------------------------------
 887 reifyType :: TypeRep.Type -> TcM TH.Type
 888 reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
 889 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
 890 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
 891 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
 892 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
 893                                  ; tau' <- reifyType tau
 894                                  ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
 895                             where
 896                                 (tvs, cxt, tau) = tcSplitSigmaTy ty
 897 reifyType (PredTy {}) = panic "reifyType PredTy"
 898
 899 reifyTypes :: [Type] -> TcM [TH.Type]
 900 reifyTypes = mapM reifyType
 901 reifyCxt :: [PredType] -> TcM [TH.Type]
 902 reifyCxt   = mapM reifyPred
 903
 904 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
 905 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
 906
 907 reifyTyVars :: [TyVar] -> [TH.Name]
 908 reifyTyVars = map reifyName
 909
 910 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 911 reify_tc_app tc tys = do { tys' <- reifyTypes tys
 912                          ; return (foldl TH.AppT (TH.ConT tc) tys') }
 913
 914 reifyPred :: TypeRep.PredType -> TcM TH.Type
 915 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
 916 reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
 917 reifyPred (EqPred {})      = panic "reifyPred EqPred"
 918
 919
 920 ------------------------------
 921 reifyName :: NamedThing n => n -> TH.Name
 922 reifyName thing
 923   | isExternalName name = mk_varg pkg_str mod_str occ_str
 924   | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
 925         -- Many of the things we reify have local bindings, and
 926         -- NameL's aren't supposed to appear in binding positions, so
 927         -- we use NameU.  When/if we start to reify nested things, that
 928         -- have free variables, we may need to generate NameL's for them.
 929   where
 930     name    = getName thing
 931     mod     = ASSERT( isExternalName name ) nameModule name
 932     pkg_str = packageIdString (modulePackageId mod)
 933     mod_str = moduleNameString (moduleName mod)
 934     occ_str = occNameString occ
 935     occ     = nameOccName name
 936     mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
 937             | OccName.isVarOcc  occ = TH.mkNameG_v
 938             | OccName.isTcOcc   occ = TH.mkNameG_tc
 939             | otherwise             = pprPanic "reifyName" (ppr name)
 940
 941 ------------------------------
 942 reifyFixity :: Name -> TcM TH.Fixity
 943 reifyFixity name
 944   = do  { fix <- lookupFixityRn name
 945         ; return (conv_fix fix) }
 946     where
 947       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
 948       conv_dir BasicTypes.InfixR = TH.InfixR
 949       conv_dir BasicTypes.InfixL = TH.InfixL
 950       conv_dir BasicTypes.InfixN = TH.InfixN
 951
 952 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
 953 reifyStrict MarkedStrict    = TH.IsStrict
 954 reifyStrict MarkedUnboxed   = TH.IsStrict
 955 reifyStrict NotMarkedStrict = TH.NotStrict
 956
 957 ------------------------------
 958 noTH :: LitString -> SDoc -> TcM a
 959 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
 960                                 ptext (sLit "in Template Haskell:"),
 961                              nest 2 d])
 962 \end{code}