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