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