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     typeable_class <- tcLookupClass typeableClassName
 385     data_class <- tcLookupClass dataClassName
 386
 387     -- Check the instances we require live in another module (we want to execute it..)
 388     -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
 389     -- also resolves the LIE constraints to detect e.g. instance ambiguity
 390     ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
 391                 expr' <- tcPolyExprNC expr expr_ty
 392                 -- By instantiating the call >here< it gets registered in the
 393                 -- LIE consulted by tcSimplifyStagedExpr
 394                 -- and hence ensures the appropriate dictionary is bound by const_binds
 395                 wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
 396                 return (wrapper, expr')
 397
 398     -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
 399     loc <- getSrcSpanM
 400     to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
 401     let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
 402         wrapped_expr' = mkHsDictLet const_binds $
 403                         L loc (HsApp specialised_to_annotation_wrapper_expr expr')
 404
 405     -- If we have type checking problems then potentially zonking
 406     -- (and certainly compilation) may fail. Give up NOW!
 407     failIfErrsM
 408
 409     -- Zonk the type variables out of that raw expression. Note that
 410     -- in particular we don't call recordThUse, since we don't
 411     -- necessarily use any code or definitions from that package.
 412     zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr'
 413
 414     -- Run the appropriately wrapped expression to get the value of
 415     -- the annotation and its dictionaries. The return value is of
 416     -- type AnnotationWrapper by construction, so this conversion is
 417     -- safe
 418     flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
 419         case annotation_wrapper of
 420             AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
 421                 -- Got the value and dictionaries: build the serialized value and
 422                 -- call it a day. We ensure that we seq the entire serialized value
 423                 -- in order that any errors in the user-written code for the
 424                 -- annotation are exposed at this point.  This is also why we are
 425                 -- doing all this stuff inside the context of runMeta: it has the
 426                 -- facilities to deal with user error in a meta-level expression
 427                 seqSerialized serialized `seq` Annotation {
 428                     ann_target = target,
 429                     ann_value = serialized
 430                 }
 431 \end{code}
 432
 433
 434 %************************************************************************
 435 %*                                                                      *
 436         Quasi-quoting
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 Note [Quasi-quote overview]
 441 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 442 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
 443 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
 444 Workshop 2007).
 445
 446 Briefly, one writes
 447         [:p| stuff |]
 448 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
 449 type should be Language.Haskell.TH.Quote.QuasiQuoter.  'p' must be
 450 defined in another module, because we are going to run it here.  It's
 451 a bit like a TH splice:
 452         $(p "stuff")
 453
 454 However, you can do this in patterns as well as terms.  Becuase of this,
 455 the splice is run by the *renamer* rather than the type checker.
 456
 457 \begin{code}
 458 runQuasiQuote :: Outputable hs_syn
 459               => HsQuasiQuote Name      -- Contains term of type QuasiQuoter, and the String
 460               -> Name                   -- Of type QuasiQuoter -> String -> Q th_syn
 461               -> String                 -- Documentation string only
 462               -> Name                   -- Name of th_syn type
 463               -> (SrcSpan -> th_syn -> Either Message hs_syn)
 464               -> TcM hs_syn
 465 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
 466   = do  { -- Check that the quoter is not locally defined, otherwise the TH
 467           -- machinery will not be able to run the quasiquote.
 468         ; this_mod <- getModule
 469         ; let is_local = case nameModule_maybe quoter of
 470                            Just mod | mod == this_mod -> True
 471                                     | otherwise       -> False
 472                            Nothing -> True
 473         ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
 474         ; checkTc (not is_local) (quoteStageError quoter)
 475
 476           -- Build the expression
 477         ; let quoterExpr = L q_span $! HsVar $! quoter
 478         ; let quoteExpr = L q_span $! HsLit $! HsString quote
 479         ; let expr = L q_span $
 480                      HsApp (L q_span $
 481                             HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
 482         ; recordThUse
 483         ; meta_exp_ty <- tcMetaTy meta_ty
 484
 485         -- Typecheck the expression
 486         ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
 487
 488         -- Run the expression
 489         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 490         ; result <- runMetaQ convert zonked_q_expr
 491         ; traceTc (text "Got result" <+> ppr result)
 492         ; showSplice desc zonked_q_expr (ppr result)
 493         ; return result
 494         }
 495
 496 runQuasiQuoteExpr quasiquote
 497     = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
 498
 499 runQuasiQuotePat quasiquote
 500     = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
 501
 502 quoteStageError :: Name -> SDoc
 503 quoteStageError quoter
 504   = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
 505          nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
 506 \end{code}
 507
 508
 509 %************************************************************************
 510 %*                                                                      *
 511                 Splicing a type
 512 %*                                                                      *
 513 %************************************************************************
 514
 515 Very like splicing an expression, but we don't yet share code.
 516
 517 \begin{code}
 518 kcSpliceType (HsSplice name hs_expr)
 519   = setSrcSpan (getLoc hs_expr) $ do
 520         { level <- getStage
 521         ; case spliceOK level of {
 522                 Nothing         -> failWithTc (illegalSplice level) ;
 523                 Just next_level -> do
 524
 525         { case level of {
 526                 Comp _                 -> do { (t,k) <- kcTopSpliceType hs_expr
 527                                              ; return (unLoc t, k) } ;
 528                 Brack _ ps_var lie_var -> do
 529
 530         {       -- A splice inside brackets
 531         ; meta_ty <- tcMetaTy typeQTyConName
 532         ; expr' <- setStage (Splice next_level) $
 533                    setLIEVar lie_var            $
 534                    tcMonoExpr hs_expr meta_ty
 535
 536                 -- Write the pending splice into the bucket
 537         ; ps <- readMutVar ps_var
 538         ; writeMutVar ps_var ((name,expr') : ps)
 539
 540         -- e.g.   [| Int -> $(h 4) |]
 541         -- Here (h 4) :: Q Type
 542         -- but $(h 4) :: forall a.a     i.e. any kind
 543         ; kind <- newKindVar
 544         ; return (panic "kcSpliceType", kind)   -- The returned type is ignored
 545     }
 546         ; Splice {} -> panic "kcSpliceType Splice"
 547     }}}}
 548
 549 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
 550 kcTopSpliceType expr
 551   = do  { meta_ty <- tcMetaTy typeQTyConName
 552
 553         -- Typecheck the expression
 554         ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
 555
 556         -- Run the expression
 557         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 558         ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
 559
 560         ; traceTc (text "Got result" <+> ppr hs_ty2)
 561
 562         ; showSplice "type" zonked_q_expr (ppr hs_ty2)
 563
 564         -- Rename it, but bale out if there are errors
 565         -- otherwise the type checker just gives more spurious errors
 566         ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
 567         ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
 568
 569         ; kcHsType hs_ty3 }
 570 \end{code}
 571
 572 %************************************************************************
 573 %*                                                                      *
 574 \subsection{Splicing an expression}
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 \begin{code}
 579 -- Always at top level
 580 -- Type sig at top of file:
 581 --      tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 582 tcSpliceDecls expr
 583   = do  { meta_dec_ty <- tcMetaTy decTyConName
 584         ; meta_q_ty <- tcMetaTy qTyConName
 585         ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
 586         ; zonked_q_expr <- tcTopSpliceExpr expr list_q
 587
 588                 -- Run the expression
 589         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 590         ; decls <- runMetaD convertToHsDecls zonked_q_expr
 591
 592         ; traceTc (text "Got result" <+> vcat (map ppr decls))
 593         ; showSplice "declarations"
 594                      zonked_q_expr
 595                      (ppr (getLoc expr) $$ (vcat (map ppr decls)))
 596         ; return decls }
 597 \end{code}
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection{Running an expression}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 \begin{code}
 607 runMetaAW :: (AnnotationWrapper -> output)
 608           -> LHsExpr Id         -- Of type AnnotationWrapper
 609           -> TcM output
 610 runMetaAW k = runMeta False (\_ -> return . Right . k)
 611     -- We turn off showing the code in meta-level exceptions because doing so exposes
 612     -- the toAnnotationWrapper function that we slap around the users code
 613
 614 runQThen :: (SrcSpan -> input -> Either Message output)
 615          -> SrcSpan
 616          -> TH.Q input
 617          -> TcM (Either Message output)
 618 runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
 619
 620 runMetaQ :: (SrcSpan -> input -> Either Message output)
 621          -> LHsExpr Id
 622          -> TcM output
 623 runMetaQ = runMeta True . runQThen
 624
 625 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
 626          -> LHsExpr Id          -- Of type (Q Exp)
 627          -> TcM (LHsExpr RdrName)
 628 runMetaE = runMetaQ
 629
 630 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
 631          -> LHsExpr Id          -- Of type (Q Pat)
 632          -> TcM (Pat RdrName)
 633 runMetaP = runMetaQ
 634
 635 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
 636          -> LHsExpr Id          -- Of type (Q Type)
 637          -> TcM (LHsType RdrName)
 638 runMetaT = runMetaQ
 639
 640 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
 641          -> LHsExpr Id          -- Of type Q [Dec]
 642          -> TcM [LHsDecl RdrName]
 643 runMetaD = runMetaQ
 644
 645 runMeta :: Bool                 -- Whether code should be printed in the exception message
 646         -> (SrcSpan -> input -> TcM (Either Message output))
 647         -> LHsExpr Id           -- Of type X
 648         -> TcM output           -- Of type t
 649 runMeta show_code run_and_convert expr
 650   = do  {       -- Desugar
 651           ds_expr <- initDsTc (dsLExpr expr)
 652         -- Compile and link it; might fail if linking fails
 653         ; hsc_env <- getTopEnv
 654         ; src_span <- getSrcSpanM
 655         ; either_hval <- tryM $ liftIO $
 656                          HscMain.compileExpr hsc_env src_span ds_expr
 657         ; case either_hval of {
 658             Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
 659             Right hval -> do
 660
 661         {       -- Coerce it to Q t, and run it
 662
 663                 -- Running might fail if it throws an exception of any kind (hence tryAllM)
 664                 -- including, say, a pattern-match exception in the code we are running
 665                 --
 666                 -- We also do the TH -> HS syntax conversion inside the same
 667                 -- exception-cacthing thing so that if there are any lurking
 668                 -- exceptions in the data structure returned by hval, we'll
 669                 -- encounter them inside the try
 670                 --
 671                 -- See Note [Exceptions in TH]
 672           let expr_span = getLoc expr
 673         ; either_tval <- tryAllM $
 674                          setSrcSpan expr_span $ -- Set the span so that qLocation can
 675                                                 -- see where this splice is
 676              do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
 677                 ; case mb_result of
 678                     Left err     -> failWithTc err
 679                     Right result -> return $! result }
 680
 681         ; case either_tval of
 682             Right v -> return v
 683             Left se ->
 684                     case fromException se of
 685                     Just IOEnvFailure ->
 686                         failM -- Error already in Tc monad
 687                     _ -> failWithTc (mk_msg "run" se)   -- Exception
 688         }}}
 689   where
 690     mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
 691                          nest 2 (text (Panic.showException exn)),
 692                          if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
 693 \end{code}
 694
 695 Note [Exceptions in TH]
 696 ~~~~~~~~~~~~~~~~~~~~~~~
 697 Supppose we have something like this
 698         $( f 4 )
 699 where
 700         f :: Int -> Q [Dec]
 701         f n | n>3       = fail "Too many declarations"
 702             | otherwise = ...
 703
 704 The 'fail' is a user-generated failure, and should be displayed as a
 705 perfectly ordinary compiler error message, not a panic or anything
 706 like that.  Here's how it's processed:
 707
 708   * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
 709     effectively transforms (fail s) to
 710         qReport True s >> fail
 711     where 'qReport' comes from the Quasi class and fail from its monad
 712     superclass.
 713
 714   * The TcM monad is an instance of Quasi (see TcSplice), and it implements
 715     (qReport True s) by using addErr to add an error message to the bag of errors.
 716     The 'fail' in TcM raises an IOEnvFailure exception
 717
 718   * So, when running a splice, we catch all exceptions; then for
 719         - an IOEnvFailure exception, we assume the error is already
 720                 in the error-bag (above)
 721         - other errors, we add an error to the bag
 722     and then fail
 723
 724
 725 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
 726
 727 \begin{code}
 728 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
 729   qNewName s = do { u <- newUnique
 730                   ; let i = getKey u
 731                   ; return (TH.mkNameU s i) }
 732
 733   qReport True msg  = addErr (text msg)
 734   qReport False msg = addReport (text msg)
 735
 736   qLocation = do { m <- getModule
 737                  ; l <- getSrcSpanM
 738                  ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
 739                                   , TH.loc_module   = moduleNameString (moduleName m)
 740                                   , TH.loc_package  = packageIdString (modulePackageId m)
 741                                   , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
 742                                   , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
 743
 744   qReify v = reify v
 745
 746         -- For qRecover, discard error messages if
 747         -- the recovery action is chosen.  Otherwise
 748         -- we'll only fail higher up.  c.f. tryTcLIE_
 749   qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
 750                              ; case mb_res of
 751                                  Just val -> do { addMessages msgs      -- There might be warnings
 752                                                 ; return val }
 753                                  Nothing  -> recover                    -- Discard all msgs
 754                           }
 755
 756   qRunIO io = liftIO io
 757 \end{code}
 758
 759
 760 %************************************************************************
 761 %*                                                                      *
 762 \subsection{Errors and contexts}
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 \begin{code}
 767 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
 768 showSplice what before after = do
 769     loc <- getSrcSpanM
 770     traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
 771                        nest 2 (sep [nest 2 (ppr before),
 772                                     text "======>",
 773                                     nest 2 after])])
 774
 775 illegalBracket :: ThStage -> SDoc
 776 illegalBracket level
 777   = ptext (sLit "Illegal bracket at level") <+> ppr level
 778
 779 illegalSplice :: ThStage -> SDoc
 780 illegalSplice level
 781   = ptext (sLit "Illegal splice at level") <+> ppr level
 782
 783 #endif  /* GHCI */
 784 \end{code}
 785
 786
 787 %************************************************************************
 788 %*                                                                      *
 789                         Reification
 790 %*                                                                      *
 791 %************************************************************************
 792
 793
 794 \begin{code}
 795 reify :: TH.Name -> TcM TH.Info
 796 reify th_name
 797   = do  { name <- lookupThName th_name
 798         ; thing <- tcLookupTh name
 799                 -- ToDo: this tcLookup could fail, which would give a
 800                 --       rather unhelpful error message
 801         ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
 802         ; reifyThing thing
 803     }
 804   where
 805     ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
 806     ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
 807     ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
 808     ppr_ns _ = panic "reify/ppr_ns"
 809
 810 lookupThName :: TH.Name -> TcM Name
 811 lookupThName th_name = do
 812     mb_name <- lookupThName_maybe th_name
 813     case mb_name of
 814         Nothing   -> failWithTc (notInScope th_name)
 815         Just name -> return name
 816
 817 lookupThName_maybe th_name
 818   =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
 819           -- Pick the first that works
 820           -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
 821         ; return (listToMaybe names) }
 822   where
 823     lookup rdr_name
 824         = do {  -- Repeat much of lookupOccRn, becase we want
 825                 -- to report errors in a TH-relevant way
 826              ; rdr_env <- getLocalRdrEnv
 827              ; case lookupLocalRdrEnv rdr_env rdr_name of
 828                  Just name -> return (Just name)
 829                  Nothing | not (isSrcRdrName rdr_name)  -- Exact, Orig
 830                          -> do { name <- lookupImportedName rdr_name
 831                                ; return (Just name) }
 832                          | otherwise                    -- Unqual, Qual
 833                          -> lookupSrcOcc_maybe rdr_name }
 834
 835 tcLookupTh :: Name -> TcM TcTyThing
 836 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
 837 -- it gives a reify-related error message on failure, whereas in the normal
 838 -- tcLookup, failure is a bug.
 839 tcLookupTh name
 840   = do  { (gbl_env, lcl_env) <- getEnvs
 841         ; case lookupNameEnv (tcl_env lcl_env) name of {
 842                 Just thing -> return thing;
 843                 Nothing    -> do
 844         { if nameIsLocalOrFrom (tcg_mod gbl_env) name
 845           then  -- It's defined in this module
 846               case lookupNameEnv (tcg_type_env gbl_env) name of
 847                 Just thing -> return (AGlobal thing)
 848                 Nothing    -> failWithTc (notInEnv name)
 849
 850           else do               -- It's imported
 851         { (eps,hpt) <- getEpsAndHpt
 852         ; dflags <- getDOpts
 853         ; case lookupType dflags hpt (eps_PTE eps) name of
 854             Just thing -> return (AGlobal thing)
 855             Nothing    -> do { thing <- tcImportDecl name
 856                              ; return (AGlobal thing) }
 857                 -- Imported names should always be findable;
 858                 -- if not, we fail hard in tcImportDecl
 859     }}}}
 860
 861 notInScope :: TH.Name -> SDoc
 862 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
 863                      ptext (sLit "is not in scope at a reify")
 864         -- Ugh! Rather an indirect way to display the name
 865
 866 notInEnv :: Name -> SDoc
 867 notInEnv name = quotes (ppr name) <+>
 868                      ptext (sLit "is not in the type environment at a reify")
 869
 870 ------------------------------
 871 reifyThing :: TcTyThing -> TcM TH.Info
 872 -- The only reason this is monadic is for error reporting,
 873 -- which in turn is mainly for the case when TH can't express
 874 -- some random GHC extension
 875
 876 reifyThing (AGlobal (AnId id))
 877   = do  { ty <- reifyType (idType id)
 878         ; fix <- reifyFixity (idName id)
 879         ; let v = reifyName id
 880         ; case globalIdDetails id of
 881             ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
 882             _                -> return (TH.VarI     v ty Nothing fix)
 883     }
 884
 885 reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
 886 reifyThing (AGlobal (AClass cls)) = reifyClass cls
 887 reifyThing (AGlobal (ADataCon dc))
 888   = do  { let name = dataConName dc
 889         ; ty <- reifyType (idType (dataConWrapId dc))
 890         ; fix <- reifyFixity name
 891         ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
 892
 893 reifyThing (ATcId {tct_id = id, tct_type = ty})
 894   = do  { ty1 <- zonkTcType ty  -- Make use of all the info we have, even
 895                                 -- though it may be incomplete
 896         ; ty2 <- reifyType ty1
 897         ; fix <- reifyFixity (idName id)
 898         ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
 899
 900 reifyThing (ATyVar tv ty)
 901   = do  { ty1 <- zonkTcType ty
 902         ; ty2 <- reifyType ty1
 903         ; return (TH.TyVarI (reifyName tv) ty2) }
 904
 905 reifyThing (AThing {}) = panic "reifyThing AThing"
 906
 907 ------------------------------
 908 reifyTyCon :: TyCon -> TcM TH.Info
 909 reifyTyCon tc
 910   | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2               False)
 911   | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
 912   | isSynTyCon tc
 913   = do { let (tvs, rhs) = synTyConDefn tc
 914        ; rhs' <- reifyType rhs
 915        ; return (TH.TyConI $
 916                    TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 917
 918 reifyTyCon tc
 919   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
 920         ; let tvs = tyConTyVars tc
 921         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
 922         ; let name = reifyName tc
 923               r_tvs  = reifyTyVars tvs
 924               deriv = []        -- Don't know about deriving
 925               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
 926                    | otherwise     = TH.DataD    cxt name r_tvs cons      deriv
 927         ; return (TH.TyConI decl) }
 928
 929 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
 930 reifyDataCon tys dc
 931   | isVanillaDataCon dc
 932   = do  { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
 933         ; let stricts = map reifyStrict (dataConStrictMarks dc)
 934               fields  = dataConFieldLabels dc
 935               name    = reifyName dc
 936               [a1,a2] = arg_tys
 937               [s1,s2] = stricts
 938         ; ASSERT( length arg_tys == length stricts )
 939           if not (null fields) then
 940              return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
 941           else
 942           if dataConIsInfix dc then
 943              ASSERT( length arg_tys == 2 )
 944              return (TH.InfixC (s1,a1) name (s2,a2))
 945           else
 946              return (TH.NormalC name (stricts `zip` arg_tys)) }
 947   | otherwise
 948   = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
 949                 <+> quotes (ppr dc))
 950
 951 ------------------------------
 952 reifyClass :: Class -> TcM TH.Info
 953 reifyClass cls
 954   = do  { cxt <- reifyCxt theta
 955         ; ops <- mapM reify_op op_stuff
 956         ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
 957   where
 958     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
 959     fds' = map reifyFunDep fds
 960     reify_op (op, _) = do { ty <- reifyType (idType op)
 961                           ; return (TH.SigD (reifyName op) ty) }
 962
 963 ------------------------------
 964 reifyType :: TypeRep.Type -> TcM TH.Type
 965 reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
 966 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
 967 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
 968 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
 969 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
 970                                  ; tau' <- reifyType tau
 971                                  ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
 972                             where
 973                                 (tvs, cxt, tau) = tcSplitSigmaTy ty
 974 reifyType (PredTy {}) = panic "reifyType PredTy"
 975
 976 reifyTypes :: [Type] -> TcM [TH.Type]
 977 reifyTypes = mapM reifyType
 978 reifyCxt :: [PredType] -> TcM [TH.Type]
 979 reifyCxt   = mapM reifyPred
 980
 981 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
 982 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
 983
 984 reifyTyVars :: [TyVar] -> [TH.Name]
 985 reifyTyVars = map reifyName
 986
 987 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 988 reify_tc_app tc tys = do { tys' <- reifyTypes tys
 989                          ; return (foldl TH.AppT (TH.ConT tc) tys') }
 990
 991 reifyPred :: TypeRep.PredType -> TcM TH.Type
 992 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
 993 reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
 994 reifyPred (EqPred {})      = panic "reifyPred EqPred"
 995
 996
 997 ------------------------------
 998 reifyName :: NamedThing n => n -> TH.Name
 999 reifyName thing
1000   | isExternalName name = mk_varg pkg_str mod_str occ_str
1001   | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
1002         -- Many of the things we reify have local bindings, and
1003         -- NameL's aren't supposed to appear in binding positions, so
1004         -- we use NameU.  When/if we start to reify nested things, that
1005         -- have free variables, we may need to generate NameL's for them.
1006   where
1007     name    = getName thing
1008     mod     = ASSERT( isExternalName name ) nameModule name
1009     pkg_str = packageIdString (modulePackageId mod)
1010     mod_str = moduleNameString (moduleName mod)
1011     occ_str = occNameString occ
1012     occ     = nameOccName name
1013     mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1014             | OccName.isVarOcc  occ = TH.mkNameG_v
1015             | OccName.isTcOcc   occ = TH.mkNameG_tc
1016             | otherwise             = pprPanic "reifyName" (ppr name)
1017
1018 ------------------------------
1019 reifyFixity :: Name -> TcM TH.Fixity
1020 reifyFixity name
1021   = do  { fix <- lookupFixityRn name
1022         ; return (conv_fix fix) }
1023     where
1024       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1025       conv_dir BasicTypes.InfixR = TH.InfixR
1026       conv_dir BasicTypes.InfixL = TH.InfixL
1027       conv_dir BasicTypes.InfixN = TH.InfixN
1028
1029 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
1030 reifyStrict MarkedStrict    = TH.IsStrict
1031 reifyStrict MarkedUnboxed   = TH.IsStrict
1032 reifyStrict NotMarkedStrict = TH.NotStrict
1033
1034 ------------------------------
1035 noTH :: LitString -> SDoc -> TcM a
1036 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1037                                 ptext (sLit "in Template Haskell:"),
1038                              nest 2 d])
1039 \end{code}