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