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