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( kcSpliceType, 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
 217   = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
 218                    2 (ppr brack)) $
 219     do { level <- getStage
 220        ; case bracketOK level of {
 221            Nothing         -> failWithTc (illegalBracket level) ;
 222            Just next_level -> do {
 223
 224         -- Typecheck expr to make sure it is valid,
 225         -- but throw away the results.  We'll type check
 226         -- it again when we actually use it.
 227           recordThUse
 228        ; pending_splices <- newMutVar []
 229        ; lie_var <- getLIEVar
 230
 231        ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
 232                                     (getLIE (tc_bracket next_level brack))
 233        ; tcSimplifyBracket lie
 234
 235         -- Make the expected type have the right shape
 236        ; boxyUnify meta_ty res_ty
 237
 238         -- Return the original expression, not the type-decorated one
 239        ; pendings <- readMutVar pending_splices
 240        ; return (noLoc (HsBracketOut brack pendings)) }}}
 241
 242 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
 243 tc_bracket use_lvl (VarBr name)         -- Note [Quoting names]
 244   = do  { thing <- tcLookup name
 245         ; case thing of
 246             AGlobal _ -> return ()
 247             ATcId { tct_level = bind_lvl, tct_id = id }
 248                 | thTopLevelId id       -- C.f thTopLevelId case of
 249                 -> keepAliveTc id       --     TcExpr.thBrackId
 250                 | otherwise
 251                 -> do { checkTc (use_lvl == bind_lvl)
 252                                 (quotedNameStageErr name) }
 253             _ -> pprPanic "th_bracket" (ppr name)
 254
 255         ; tcMetaTy nameTyConName        -- Result type is Var (not Q-monadic)
 256         }
 257
 258 tc_bracket _ (ExpBr expr)
 259   = do  { any_ty <- newFlexiTyVarTy liftedTypeKind
 260         ; tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
 261         ; tcMetaTy expQTyConName }
 262         -- Result type is Expr (= Q Exp)
 263
 264 tc_bracket _ (TypBr typ)
 265   = do  { tcHsSigTypeNC ThBrackCtxt typ
 266         ; tcMetaTy typeQTyConName }
 267         -- Result type is Type (= Q Typ)
 268
 269 tc_bracket _ (DecBr decls)
 270   = do  {  tcTopSrcDecls emptyModDetails decls
 271         -- Typecheck the declarations, dicarding the result
 272         -- We'll get all that stuff later, when we splice it in
 273
 274         ; decl_ty <- tcMetaTy decTyConName
 275         ; q_ty    <- tcMetaTy qTyConName
 276         ; return (mkAppTy q_ty (mkListTy decl_ty))
 277         -- Result type is Q [Dec]
 278     }
 279
 280 tc_bracket _ (PatBr _)
 281   = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
 282
 283 quotedNameStageErr :: Name -> SDoc
 284 quotedNameStageErr v
 285   = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
 286         , ptext (sLit "must be used at the same stage at which is is bound")]
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Splicing an expression}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 \begin{code}
 297 tcSpliceExpr (HsSplice name expr) res_ty
 298   = setSrcSpan (getLoc expr)    $ do
 299     level <- getStage
 300     case spliceOK level of {
 301         Nothing         -> failWithTc (illegalSplice level) ;
 302         Just next_level ->
 303
 304      case level of {
 305         Comp _                 -> do { e <- tcTopSplice expr res_ty
 306                                      ; return (unLoc e) } ;
 307         Brack _ ps_var lie_var -> do
 308
 309         -- A splice inside brackets
 310         -- NB: ignore res_ty, apart from zapping it to a mono-type
 311         -- e.g.   [| reverse $(h 4) |]
 312         -- Here (h 4) :: Q Exp
 313         -- but $(h 4) :: forall a.a     i.e. anything!
 314
 315       unBox res_ty
 316       meta_exp_ty <- tcMetaTy expQTyConName
 317       expr' <- setStage (Splice next_level) (
 318                  setLIEVar lie_var    $
 319                  tcMonoExpr expr meta_exp_ty
 320                )
 321
 322         -- Write the pending splice into the bucket
 323       ps <- readMutVar ps_var
 324       writeMutVar ps_var ((name,expr') : ps)
 325
 326       return (panic "tcSpliceExpr")     -- The returned expression is ignored
 327
 328      ; Splice {} -> panic "tcSpliceExpr Splice"
 329      }}
 330
 331 -- tcTopSplice used to have this:
 332 -- Note that we do not decrement the level (to -1) before
 333 -- typechecking the expression.  For example:
 334 --      f x = $( ...$(g 3) ... )
 335 -- The recursive call to tcMonoExpr will simply expand the
 336 -- inner escape before dealing with the outer one
 337
 338 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
 339 tcTopSplice expr res_ty = do
 340     meta_exp_ty <- tcMetaTy expQTyConName
 341
 342         -- Typecheck the expression
 343     zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
 344
 345         -- Run the expression
 346     traceTc (text "About to run" <+> ppr zonked_q_expr)
 347     expr2 <- runMetaE convertToHsExpr zonked_q_expr
 348
 349     traceTc (text "Got result" <+> ppr expr2)
 350
 351     showSplice "expression" 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 quoteExpr (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" 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         ; kcLHsType 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                      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 Name -> SDoc -> TcM ()
 767 -- Note that 'before' is *renamed* but not *typechecked*
 768 -- Reason (a) less typechecking crap
 769 --        (b) data constructors after type checking have been
 770 --            changed to their *wrappers*, and that makes them
 771 --            print always fully qualified
 772 showSplice what before after
 773   = do { loc <- getSrcSpanM
 774        ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
 775                             nest 2 (sep [nest 2 (ppr before),
 776                                          text "======>",
 777                                          nest 2 after])]) }
 778
 779 illegalBracket :: ThStage -> SDoc
 780 illegalBracket level
 781   = ptext (sLit "Illegal bracket at level") <+> ppr level
 782
 783 illegalSplice :: ThStage -> SDoc
 784 illegalSplice level
 785   = ptext (sLit "Illegal splice at level") <+> ppr level
 786
 787 #endif  /* GHCI */
 788 \end{code}
 789
 790
 791 %************************************************************************
 792 %*                                                                      *
 793                         Reification
 794 %*                                                                      *
 795 %************************************************************************
 796
 797
 798 \begin{code}
 799 reify :: TH.Name -> TcM TH.Info
 800 reify th_name
 801   = do  { name <- lookupThName th_name
 802         ; thing <- tcLookupTh name
 803                 -- ToDo: this tcLookup could fail, which would give a
 804                 --       rather unhelpful error message
 805         ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
 806         ; reifyThing thing
 807     }
 808   where
 809     ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
 810     ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
 811     ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
 812     ppr_ns _ = panic "reify/ppr_ns"
 813
 814 lookupThName :: TH.Name -> TcM Name
 815 lookupThName th_name = do
 816     mb_name <- lookupThName_maybe th_name
 817     case mb_name of
 818         Nothing   -> failWithTc (notInScope th_name)
 819         Just name -> return name
 820
 821 lookupThName_maybe th_name
 822   =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
 823           -- Pick the first that works
 824           -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
 825         ; return (listToMaybe names) }
 826   where
 827     lookup rdr_name
 828         = do {  -- Repeat much of lookupOccRn, becase we want
 829                 -- to report errors in a TH-relevant way
 830              ; rdr_env <- getLocalRdrEnv
 831              ; case lookupLocalRdrEnv rdr_env rdr_name of
 832                  Just name -> return (Just name)
 833                  Nothing   -> lookupGlobalOccRn_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 idDetails 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
 892                               (reifyName (dataConOrigTyCon dc)) fix)
 893         }
 894
 895 reifyThing (ATcId {tct_id = id, tct_type = ty})
 896   = do  { ty1 <- zonkTcType ty  -- Make use of all the info we have, even
 897                                 -- though it may be incomplete
 898         ; ty2 <- reifyType ty1
 899         ; fix <- reifyFixity (idName id)
 900         ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
 901
 902 reifyThing (ATyVar tv ty)
 903   = do  { ty1 <- zonkTcType ty
 904         ; ty2 <- reifyType ty1
 905         ; return (TH.TyVarI (reifyName tv) ty2) }
 906
 907 reifyThing (AThing {}) = panic "reifyThing AThing"
 908
 909 ------------------------------
 910 reifyTyCon :: TyCon -> TcM TH.Info
 911 reifyTyCon tc
 912   | isFunTyCon tc
 913   = return (TH.PrimTyConI (reifyName tc) 2                False)
 914   | isPrimTyCon tc
 915   = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
 916   | isOpenTyCon tc
 917   = let flavour = reifyFamFlavour tc
 918         tvs     = tyConTyVars tc
 919         kind    = tyConKind tc
 920         kind'
 921           | isLiftedTypeKind kind = Nothing
 922           | otherwise             = Just $ reifyKind kind
 923     in
 924     return (TH.TyConI $
 925               TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
 926   | isSynTyCon tc
 927   = do { let (tvs, rhs) = synTyConDefn tc
 928        ; rhs' <- reifyType rhs
 929        ; return (TH.TyConI $
 930                    TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
 931        }
 932
 933 reifyTyCon tc
 934   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
 935         ; let tvs = tyConTyVars tc
 936         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
 937         ; let name = reifyName tc
 938               r_tvs  = reifyTyVars tvs
 939               deriv = []        -- Don't know about deriving
 940               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
 941                    | otherwise     = TH.DataD    cxt name r_tvs cons        deriv
 942         ; return (TH.TyConI decl) }
 943
 944 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
 945 reifyDataCon tys dc
 946   | isVanillaDataCon dc
 947   = do  { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
 948         ; let stricts = map reifyStrict (dataConStrictMarks dc)
 949               fields  = dataConFieldLabels dc
 950               name    = reifyName dc
 951               [a1,a2] = arg_tys
 952               [s1,s2] = stricts
 953         ; ASSERT( length arg_tys == length stricts )
 954           if not (null fields) then
 955              return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
 956           else
 957           if dataConIsInfix dc then
 958              ASSERT( length arg_tys == 2 )
 959              return (TH.InfixC (s1,a1) name (s2,a2))
 960           else
 961              return (TH.NormalC name (stricts `zip` arg_tys)) }
 962   | otherwise
 963   = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
 964                 <+> quotes (ppr dc))
 965
 966 ------------------------------
 967 reifyClass :: Class -> TcM TH.Info
 968 reifyClass cls
 969   = do  { cxt <- reifyCxt theta
 970         ; ops <- mapM reify_op op_stuff
 971         ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
 972   where
 973     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
 974     fds' = map reifyFunDep fds
 975     reify_op (op, _) = do { ty <- reifyType (idType op)
 976                           ; return (TH.SigD (reifyName op) ty) }
 977
 978 ------------------------------
 979 reifyType :: TypeRep.Type -> TcM TH.Type
 980 reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
 981 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
 982 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
 983 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
 984 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
 985                                  ; tau' <- reifyType tau
 986                                  ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
 987                             where
 988                                 (tvs, cxt, tau) = tcSplitSigmaTy ty
 989 reifyType (PredTy {}) = panic "reifyType PredTy"
 990
 991 reifyTypes :: [Type] -> TcM [TH.Type]
 992 reifyTypes = mapM reifyType
 993
 994 reifyKind :: Kind -> TH.Kind
 995 reifyKind  ki
 996   = let (kis, ki') = splitKindFunTys ki
 997         kis_rep    = map reifyKind kis
 998         ki'_rep    = reifyNonArrowKind ki'
 999     in
1000     foldl TH.ArrowK ki'_rep kis_rep
1001   where
1002     reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
1003                         | otherwise          = pprPanic "Exotic form of kind"
1004                                                         (ppr k)
1005
1006 reifyCxt :: [PredType] -> TcM [TH.Pred]
1007 reifyCxt   = mapM reifyPred
1008
1009 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1010 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1011
1012 reifyFamFlavour :: TyCon -> TH.FamFlavour
1013 reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
1014                    | isOpenTyCon    tc = TH.DataFam
1015                    | otherwise
1016                    = panic "TcSplice.reifyFamFlavour: not a type family"
1017
1018 reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
1019 reifyTyVars = map reifyTyVar
1020   where
1021     reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
1022                   | otherwise             = TH.KindedTV name (reifyKind kind)
1023       where
1024         kind = tyVarKind tv
1025         name = reifyName tv
1026
1027 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
1028 reify_tc_app tc tys = do { tys' <- reifyTypes tys
1029                          ; return (foldl TH.AppT (TH.ConT tc) tys') }
1030
1031 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1032 reifyPred (ClassP cls tys)
1033   = do { tys' <- reifyTypes tys
1034        ; return $ TH.ClassP (reifyName cls) tys'
1035        }
1036 reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
1037 reifyPred (EqPred ty1 ty2)
1038   = do { ty1' <- reifyType ty1
1039        ; ty2' <- reifyType ty2
1040        ; return $ TH.EqualP ty1' ty2'
1041        }
1042
1043
1044 ------------------------------
1045 reifyName :: NamedThing n => n -> TH.Name
1046 reifyName thing
1047   | isExternalName name = mk_varg pkg_str mod_str occ_str
1048   | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
1049         -- Many of the things we reify have local bindings, and
1050         -- NameL's aren't supposed to appear in binding positions, so
1051         -- we use NameU.  When/if we start to reify nested things, that
1052         -- have free variables, we may need to generate NameL's for them.
1053   where
1054     name    = getName thing
1055     mod     = ASSERT( isExternalName name ) nameModule name
1056     pkg_str = packageIdString (modulePackageId mod)
1057     mod_str = moduleNameString (moduleName mod)
1058     occ_str = occNameString occ
1059     occ     = nameOccName name
1060     mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1061             | OccName.isVarOcc  occ = TH.mkNameG_v
1062             | OccName.isTcOcc   occ = TH.mkNameG_tc
1063             | otherwise             = pprPanic "reifyName" (ppr name)
1064
1065 ------------------------------
1066 reifyFixity :: Name -> TcM TH.Fixity
1067 reifyFixity name
1068   = do  { fix <- lookupFixityRn name
1069         ; return (conv_fix fix) }
1070     where
1071       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1072       conv_dir BasicTypes.InfixR = TH.InfixR
1073       conv_dir BasicTypes.InfixL = TH.InfixL
1074       conv_dir BasicTypes.InfixN = TH.InfixN
1075
1076 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
1077 reifyStrict MarkedStrict    = TH.IsStrict
1078 reifyStrict MarkedUnboxed   = TH.IsStrict
1079 reifyStrict NotMarkedStrict = TH.NotStrict
1080
1081 ------------------------------
1082 noTH :: LitString -> SDoc -> TcM a
1083 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1084                                 ptext (sLit "in Template Haskell:"),
1085                              nest 2 d])
1086 \end{code}