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