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