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