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
   9 \begin{code}
  10 {-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
  11 -- The above warning supression flag is a temporary kludge.
  12 -- While working on this module you are encouraged to remove it and fix
  13 -- any warnings in the module. See
  14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  15 -- for details
  16
  17 module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
  18                  lookupThName_maybe,
  19                  runQuasiQuoteExpr, runQuasiQuotePat,
  20                  runQuasiQuoteDecl, runQuasiQuoteType,
  21                  runAnnotation ) where
  22
  23 #include "HsVersions.h"
  24
  25 import HscMain
  26 import TcRnDriver
  27         -- These imports are the reason that TcSplice
  28         -- is very high up the module hierarchy
  29
  30 import HsSyn
  31 import Convert
  32 import RnExpr
  33 import RnEnv
  34 import RdrName
  35 import RnTypes
  36 import TcPat
  37 import TcExpr
  38 import TcHsSyn
  39 import TcSimplify
  40 import TcUnify
  41 import TcType
  42 import TcEnv
  43 import TcMType
  44 import TcHsType
  45 import TcIface
  46 import TypeRep
  47 import InstEnv
  48 import Name
  49 import NameEnv
  50 import NameSet
  51 import PrelNames
  52 import HscTypes
  53 import OccName
  54 import Var
  55 import Module
  56 import Annotations
  57 import TcRnMonad
  58 import Class
  59 import Inst
  60 import TyCon
  61 import DataCon
  62 import Id
  63 import IdInfo
  64 import TysWiredIn
  65 import DsMeta
  66 import DsExpr
  67 import DsMonad hiding (Splice)
  68 import Serialized
  69 import ErrUtils
  70 import SrcLoc
  71 import Outputable
  72 import Util             ( dropList )
  73 import Data.List        ( mapAccumL )
  74 import Unique
  75 import Data.Maybe
  76 import BasicTypes
  77 import Panic
  78 import FastString
  79 import Exception
  80 import Control.Monad    ( when )
  81
  82 import qualified Language.Haskell.TH as TH
  83 -- THSyntax gives access to internal functions and data types
  84 import qualified Language.Haskell.TH.Syntax as TH
  85
  86 #ifdef GHCI
  87 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
  88 import GHC.Desugar      ( AnnotationWrapper(..) )
  89 #endif
  90
  91 import GHC.Exts         ( unsafeCoerce#, Int#, Int(..) )
  92 import System.IO.Error
  93 \end{code}
  94
  95 Note [How top-level splices are handled]
  96 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  97 Top-level splices (those not inside a [| .. |] quotation bracket) are handled
  98 very straightforwardly:
  99
 100   1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
 101
 102   2. runMetaT: desugar, compile, run it, and convert result back to
 103      HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
 104      HsExpr RdrName etc)
 105
 106   3. treat the result as if that's what you saw in the first place
 107      e.g for HsType, rename and kind-check
 108          for HsExpr, rename and type-check
 109
 110      (The last step is different for decls, becuase they can *only* be
 111       top-level: we return the result of step 2.)
 112
 113 Note [How brackets and nested splices are handled]
 114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 115 Nested splices (those inside a [| .. |] quotation bracket), are treated
 116 quite differently.
 117
 118   * After typechecking, the bracket [| |] carries
 119
 120      a) A mutable list of PendingSplice
 121           type PendingSplice = (Name, LHsExpr Id)
 122
 123      b) The quoted expression e, *renamed*: (HsExpr Name)
 124           The expression e has been typechecked, but the result of
 125           that typechecking is discarded.
 126
 127   * The brakcet is desugared by DsMeta.dsBracket.  It
 128
 129       a) Extends the ds_meta environment with the PendingSplices
 130          attached to the bracket
 131
 132       b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
 133          run, will produce a suitable TH expression/type/decl.  This
 134          is why we leave the *renamed* expression attached to the bracket:
 135          the quoted expression should not be decorated with all the goop
 136          added by the type checker
 137
 138   * Each splice carries a unique Name, called a "splice point", thus
 139     ${n}(e).  The name is initialised to an (Unqual "splice") when the
 140     splice is created; the renamer gives it a unique.
 141
 142   * When the type checker type-checks a nested splice ${n}(e), it
 143         - typechecks e
 144         - adds the typechecked expression (of type (HsExpr Id))
 145           as a pending splice to the enclosing bracket
 146         - returns something non-committal
 147     Eg for [| f ${n}(g x) |], the typechecker
 148         - attaches the typechecked term (g x) to the pending splices for n
 149           in the outer bracket
 150         - returns a non-committal type \alpha.
 151         Remember that the bracket discards the typechecked term altogether
 152
 153   * When DsMeta (used to desugar the body of the bracket) comes across
 154     a splice, it looks up the splice's Name, n, in the ds_meta envt,
 155     to find an (HsExpr Id) that should be substituted for the splice;
 156     it just desugars it to get a CoreExpr (DsMeta.repSplice).
 157
 158 Example:
 159     Source:       f = [| Just $(g 3) |]
 160       The [| |] part is a HsBracket
 161
 162     Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
 163       The [| |] part is a HsBracketOut, containing *renamed*
 164         (not typechecked) expression
 165       The "s7" is the "splice point"; the (g Int 3) part
 166         is a typechecked expression
 167
 168     Desugared:    f = do { s7 <- g Int 3
 169                          ; return (ConE "Data.Maybe.Just" s7) }
 170
 171
 172 Note [Template Haskell state diagram]
 173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 174 Here are the ThStages, s, their corresponding level numbers
 175 (the result of (thLevel s)), and their state transitions.
 176
 177       -----------     $      ------------   $
 178       |  Comp   | ---------> |  Splice  | -----|
 179       |   1     |            |    0     | <----|
 180       -----------            ------------
 181         ^     |                ^      |
 182       $ |     | [||]         $ |      | [||]
 183         |     v                |      v
 184    --------------          ----------------
 185    | Brack Comp |          | Brack Splice |
 186    |     2      |          |      1       |
 187    --------------          ----------------
 188
 189 * Normal top-level declarations start in state Comp
 190        (which has level 1).
 191   Annotations start in state Splice, since they are
 192        treated very like a splice (only without a '$')
 193
 194 * Code compiled in state Splice (and only such code)
 195   will be *run at compile time*, with the result replacing
 196   the splice
 197
 198 * The original paper used level -1 instead of 0, etc.
 199
 200 * The original paper did not allow a splice within a
 201   splice, but there is no reason not to. This is the
 202   $ transition in the top right.
 203
 204 Note [Template Haskell levels]
 205 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 206 * Imported things are impLevel (= 0)
 207
 208 * In GHCi, variables bound by a previous command are treated
 209   as impLevel, because we have bytecode for them.
 210
 211 * Variables are bound at the "current level"
 212
 213 * The current level starts off at outerLevel (= 1)
 214
 215 * The level is decremented by splicing $(..)
 216                incremented by brackets [| |]
 217                incremented by name-quoting 'f
 218
 219 When a variable is used, we compare
 220         bind:  binding level, and
 221         use:   current level at usage site
 222
 223   Generally
 224         bind > use      Always error (bound later than used)
 225                         [| \x -> $(f x) |]
 226
 227         bind = use      Always OK (bound same stage as used)
 228                         [| \x -> $(f [| x |]) |]
 229
 230         bind < use      Inside brackets, it depends
 231                         Inside splice, OK
 232                         Inside neither, OK
 233
 234   For (bind < use) inside brackets, there are three cases:
 235     - Imported things   OK      f = [| map |]
 236     - Top-level things  OK      g = [| f |]
 237     - Non-top-level     Only if there is a liftable instance
 238                                 h = \(x:Int) -> [| x |]
 239
 240 See Note [What is a top-level Id?]
 241
 242 Note [Quoting names]
 243 ~~~~~~~~~~~~~~~~~~~~
 244 A quoted name 'n is a bit like a quoted expression [| n |], except that we
 245 have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing
 246 the use-level to account for the brackets, the cases are:
 247
 248         bind > use                      Error
 249         bind = use                      OK
 250         bind < use
 251                 Imported things         OK
 252                 Top-level things        OK
 253                 Non-top-level           Error
 254
 255 See Note [What is a top-level Id?] in TcEnv.  Examples:
 256
 257   f 'map        -- OK; also for top-level defns of this module
 258
 259   \x. f 'x      -- Not ok (whereas \x. f [| x |] might have been ok, by
 260                 --                               cross-stage lifting
 261
 262   \y. [| \x. $(f 'y) |] -- Not ok (same reason)
 263
 264   [| \x. $(f 'x) |]     -- OK
 265
 266
 267 Note [What is a top-level Id?]
 268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 269 In the level-control criteria above, we need to know what a "top level Id" is.
 270 There are three kinds:
 271   * Imported from another module                (GlobalId, ExternalName)
 272   * Bound at the top level of this module       (ExternalName)
 273   * In GHCi, bound by a previous stmt           (GlobalId)
 274 It's strange that there is no one criterion tht picks out all three, but that's
 275 how it is right now.  (The obvious thing is to give an ExternalName to GHCi Ids
 276 bound in an earlier Stmt, but what module would you choose?  See
 277 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
 278
 279 The predicate we use is TcEnv.thTopLevelId.
 280
 281
 282 %************************************************************************
 283 %*                                                                      *
 284 \subsection{Main interface + stubs for the non-GHCI case
 285 %*                                                                      *
 286 %************************************************************************
 287
 288 \begin{code}
 289 tcBracket     :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId)
 290 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 291 tcSpliceExpr  :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
 292 kcSpliceType  :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
 293         -- None of these functions add constraints to the LIE
 294
 295 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
 296
 297 runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
 298 runQuasiQuotePat  :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
 299 runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
 300 runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
 301
 302 runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 303
 304 #ifndef GHCI
 305 tcBracket     x _ = pprPanic "Cant do tcBracket without GHCi"     (ppr x)
 306 tcSpliceExpr  e   = pprPanic "Cant do tcSpliceExpr without GHCi"  (ppr e)
 307 tcSpliceDecls x   = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
 308 kcSpliceType  x fvs = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
 309
 310 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
 311
 312 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
 313 runQuasiQuotePat  q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
 314 runQuasiQuoteType q = pprPanic "Cant do runQuasiQuoteType without GHCi" (ppr q)
 315 runQuasiQuoteDecl q = pprPanic "Cant do runQuasiQuoteDecl without GHCi" (ppr q)
 316 runAnnotation   _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
 317 #else
 318 \end{code}
 319
 320 %************************************************************************
 321 %*                                                                      *
 322 \subsection{Quoting an expression}
 323 %*                                                                      *
 324 %************************************************************************
 325
 326
 327 \begin{code}
 328 -- See Note [How brackets and nested splices are handled]
 329 tcBracket brack res_ty
 330   = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
 331                    2 (ppr brack)) $
 332     do {        -- Check for nested brackets
 333          cur_stage <- getStage
 334        ; checkTc (not (isBrackStage cur_stage)) illegalBracket
 335
 336         -- Brackets are desugared to code that mentions the TH package
 337        ; recordThUse
 338
 339         -- Typecheck expr to make sure it is valid,
 340         -- but throw away the results.  We'll type check
 341         -- it again when we actually use it.
 342        ; pending_splices <- newMutVar []
 343        ; lie_var <- getConstraintVar
 344        ; let brack_stage = Brack cur_stage pending_splices lie_var
 345
 346           -- We want to check that there aren't any constraints that
 347           -- can't be satisfied (e.g. Show Foo, where Foo has no Show
 348           -- instance), but we aren't otherwise interested in the
 349           -- results. Nor do we care about ambiguous dictionaries etc.
 350           -- We will type check this bracket again at its usage site.
 351        ; _ <- newImplication BracketSkol [] [] $
 352               setStage brack_stage $
 353               do { meta_ty <- tc_bracket cur_stage brack
 354                  ; unifyType meta_ty res_ty }
 355
 356         -- Return the original expression, not the type-decorated one
 357        ; pendings <- readMutVar pending_splices
 358        ; return (noLoc (HsBracketOut brack pendings)) }
 359
 360 tc_bracket :: ThStage -> HsBracket Name -> TcM TcType
 361 tc_bracket outer_stage (VarBr name)     -- Note [Quoting names]
 362   = do  { thing <- tcLookup name
 363         ; case thing of
 364             AGlobal _ -> return ()
 365             ATcId { tct_level = bind_lvl, tct_id = id }
 366                 | thTopLevelId id       -- C.f TcExpr.checkCrossStageLifting
 367                 -> keepAliveTc id
 368                 | otherwise
 369                 -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
 370                                 (quotedNameStageErr name) }
 371             _ -> pprPanic "th_bracket" (ppr name)
 372
 373         ; tcMetaTy nameTyConName        -- Result type is Var (not Q-monadic)
 374         }
 375
 376 tc_bracket _ (ExpBr expr)
 377   = do  { any_ty <- newFlexiTyVarTy liftedTypeKind
 378         ; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
 379         ; tcMetaTy expQTyConName }
 380         -- Result type is ExpQ (= Q Exp)
 381
 382 tc_bracket _ (TypBr typ)
 383   = do  { _ <- tcHsSigTypeNC ThBrackCtxt typ
 384         ; tcMetaTy typeQTyConName }
 385         -- Result type is Type (= Q Typ)
 386
 387 tc_bracket _ (DecBrG decls)
 388   = do  { _ <- tcTopSrcDecls emptyModDetails decls
 389                -- Typecheck the declarations, dicarding the result
 390                -- We'll get all that stuff later, when we splice it in
 391
 392                -- Top-level declarations in the bracket get unqualified names
 393                -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
 394
 395         ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
 396
 397 tc_bracket _ (PatBr pat)
 398   = do  { any_ty <- newFlexiTyVarTy liftedTypeKind
 399         ; _ <- tcPat ThPatQuote pat any_ty $
 400                return ()
 401         ; tcMetaTy patQTyConName }
 402         -- Result type is PatQ (= Q Pat)
 403
 404 tc_bracket _ (DecBrL _)
 405   = panic "tc_bracket: Unexpected DecBrL"
 406
 407 quotedNameStageErr :: Name -> SDoc
 408 quotedNameStageErr v
 409   = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
 410         , ptext (sLit "must be used at the same stage at which is is bound")]
 411 \end{code}
 412
 413
 414 %************************************************************************
 415 %*                                                                      *
 416 \subsection{Splicing an expression}
 417 %*                                                                      *
 418 %************************************************************************
 419
 420 \begin{code}
 421 tcSpliceExpr (HsSplice name expr) res_ty
 422   = setSrcSpan (getLoc expr)    $ do
 423     { stage <- getStage
 424     ; case stage of {
 425         Splice -> tcTopSplice expr res_ty ;
 426         Comp   -> tcTopSplice expr res_ty ;
 427
 428         Brack pop_stage ps_var lie_var -> do
 429
 430         -- See Note [How brackets and nested splices are handled]
 431         -- A splice inside brackets
 432         -- NB: ignore res_ty, apart from zapping it to a mono-type
 433         -- e.g.   [| reverse $(h 4) |]
 434         -- Here (h 4) :: Q Exp
 435         -- but $(h 4) :: forall a.a     i.e. anything!
 436
 437      { meta_exp_ty <- tcMetaTy expQTyConName
 438      ; expr' <- setStage pop_stage $
 439                 setConstraintVar lie_var    $
 440                 tcMonoExpr expr meta_exp_ty
 441
 442         -- Write the pending splice into the bucket
 443      ; ps <- readMutVar ps_var
 444      ; writeMutVar ps_var ((name,expr') : ps)
 445
 446      ; return (panic "tcSpliceExpr")    -- The returned expression is ignored
 447      }}}
 448
 449 tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
 450 -- Note [How top-level splices are handled]
 451 tcTopSplice expr res_ty
 452   = do { meta_exp_ty <- tcMetaTy expQTyConName
 453
 454         -- Typecheck the expression
 455        ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
 456
 457         -- Run the expression
 458        ; expr2 <- runMetaE zonked_q_expr
 459        ; showSplice "expression" expr (ppr expr2)
 460
 461         -- Rename it, but bale out if there are errors
 462         -- otherwise the type checker just gives more spurious errors
 463        ; addErrCtxt (spliceResultDoc expr) $ do
 464        { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
 465
 466        ; exp4 <- tcMonoExpr exp3 res_ty
 467        ; return (unLoc exp4) } }
 468
 469 spliceResultDoc :: LHsExpr Name -> SDoc
 470 spliceResultDoc expr
 471   = sep [ ptext (sLit "In the result of the splice:")
 472         , nest 2 (char '$' <> pprParendExpr expr)
 473         , ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
 474
 475 -------------------
 476 tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
 477 -- Note [How top-level splices are handled]
 478 -- Type check an expression that is the body of a top-level splice
 479 --   (the caller will compile and run it)
 480 -- Note that set the level to Splice, regardless of the original level,
 481 -- before typechecking the expression.  For example:
 482 --      f x = $( ...$(g 3) ... )
 483 -- The recursive call to tcMonoExpr will simply expand the
 484 -- inner escape before dealing with the outer one
 485
 486 tcTopSpliceExpr tc_action
 487   = checkNoErrs $  -- checkNoErrs: must not try to run the thing
 488                    -- if the type checker fails!
 489     setStage Splice $
 490     do {    -- Typecheck the expression
 491          (expr', lie) <- captureConstraints tc_action
 492
 493         -- Solve the constraints
 494         ; const_binds <- simplifyTop lie
 495
 496           -- Zonk it and tie the knot of dictionary bindings
 497        ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
 498 \end{code}
 499
 500
 501 %************************************************************************
 502 %*                                                                      *
 503                 Splicing a type
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 Very like splicing an expression, but we don't yet share code.
 508
 509 \begin{code}
 510 kcSpliceType splice@(HsSplice name hs_expr) fvs
 511   = setSrcSpan (getLoc hs_expr) $ do
 512     { stage <- getStage
 513     ; case stage of {
 514         Splice -> kcTopSpliceType hs_expr ;
 515         Comp   -> kcTopSpliceType hs_expr ;
 516
 517         Brack pop_level ps_var lie_var -> do
 518            -- See Note [How brackets and nested splices are handled]
 519            -- A splice inside brackets
 520     { meta_ty <- tcMetaTy typeQTyConName
 521     ; expr' <- setStage pop_level $
 522                setConstraintVar lie_var $
 523                tcMonoExpr hs_expr meta_ty
 524
 525         -- Write the pending splice into the bucket
 526     ; ps <- readMutVar ps_var
 527     ; writeMutVar ps_var ((name,expr') : ps)
 528
 529     -- e.g.   [| f (g :: Int -> $(h 4)) |]
 530     -- Here (h 4) :: Q Type
 531     -- but $(h 4) :: a  i.e. any type, of any kind
 532
 533     ; kind <- newKindVar
 534     ; return (HsSpliceTy splice fvs kind, kind)
 535     }}}
 536
 537 kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
 538 -- Note [How top-level splices are handled]
 539 kcTopSpliceType expr
 540   = do  { meta_ty <- tcMetaTy typeQTyConName
 541
 542         -- Typecheck the expression
 543         ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
 544
 545         -- Run the expression
 546         ; hs_ty2 <- runMetaT zonked_q_expr
 547         ; showSplice "type" expr (ppr hs_ty2)
 548
 549         -- Rename it, but bale out if there are errors
 550         -- otherwise the type checker just gives more spurious errors
 551         ; addErrCtxt (spliceResultDoc expr) $ do
 552         { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
 553         ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
 554         ; (ty4, kind) <- kcLHsType hs_ty3
 555         ; return (unLoc ty4, kind) }}
 556 \end{code}
 557
 558 %************************************************************************
 559 %*                                                                      *
 560 \subsection{Splicing an expression}
 561 %*                                                                      *
 562 %************************************************************************
 563
 564 \begin{code}
 565 -- Note [How top-level splices are handled]
 566 -- Always at top level
 567 -- Type sig at top of file:
 568 --      tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 569 tcSpliceDecls expr
 570   = do  { list_q <- tcMetaTy decsQTyConName     -- Q [Dec]
 571         ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
 572
 573                 -- Run the expression
 574         ; decls <- runMetaD zonked_q_expr
 575         ; showSplice "declarations" expr
 576                      (ppr (getLoc expr) $$ (vcat (map ppr decls)))
 577
 578         ; return decls }
 579 \end{code}
 580
 581
 582 %************************************************************************
 583 %*                                                                      *
 584         Annotations
 585 %*                                                                      *
 586 %************************************************************************
 587
 588 \begin{code}
 589 runAnnotation target expr = do
 590     -- Find the classes we want instances for in order to call toAnnotationWrapper
 591     loc <- getSrcSpanM
 592     data_class <- tcLookupClass dataClassName
 593     to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
 594
 595     -- Check the instances we require live in another module (we want to execute it..)
 596     -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
 597     -- also resolves the LIE constraints to detect e.g. instance ambiguity
 598     zonked_wrapped_expr' <- tcTopSpliceExpr $
 599            do { (expr', expr_ty) <- tcInferRhoNC expr
 600                 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
 601                 -- By instantiating the call >here< it gets registered in the
 602                 -- LIE consulted by tcTopSpliceExpr
 603                 -- and hence ensures the appropriate dictionary is bound by const_binds
 604               ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
 605               ; let specialised_to_annotation_wrapper_expr
 606                       = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
 607               ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
 608
 609     -- Run the appropriately wrapped expression to get the value of
 610     -- the annotation and its dictionaries. The return value is of
 611     -- type AnnotationWrapper by construction, so this conversion is
 612     -- safe
 613     flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
 614         case annotation_wrapper of
 615             AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
 616                 -- Got the value and dictionaries: build the serialized value and
 617                 -- call it a day. We ensure that we seq the entire serialized value
 618                 -- in order that any errors in the user-written code for the
 619                 -- annotation are exposed at this point.  This is also why we are
 620                 -- doing all this stuff inside the context of runMeta: it has the
 621                 -- facilities to deal with user error in a meta-level expression
 622                 seqSerialized serialized `seq` Annotation {
 623                     ann_target = target,
 624                     ann_value = serialized
 625                 }
 626 \end{code}
 627
 628
 629 %************************************************************************
 630 %*                                                                      *
 631         Quasi-quoting
 632 %*                                                                      *
 633 %************************************************************************
 634
 635 Note [Quasi-quote overview]
 636 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 637 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
 638 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
 639 Workshop 2007).
 640
 641 Briefly, one writes
 642         [p| stuff |]
 643 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
 644 type should be Language.Haskell.TH.Quote.QuasiQuoter.  'p' must be
 645 defined in another module, because we are going to run it here.  It's
 646 a bit like a TH splice:
 647         $(p "stuff")
 648
 649 However, you can do this in patterns as well as terms.  Becuase of this,
 650 the splice is run by the *renamer* rather than the type checker.
 651
 652 %************************************************************************
 653 %*                                                                      *
 654 \subsubsection{Quasiquotation}
 655 %*                                                                      *
 656 %************************************************************************
 657
 658 See Note [Quasi-quote overview] in TcSplice.
 659
 660 \begin{code}
 661 runQuasiQuote :: Outputable hs_syn
 662               => HsQuasiQuote RdrName   -- Contains term of type QuasiQuoter, and the String
 663               -> Name                   -- Of type QuasiQuoter -> String -> Q th_syn
 664               -> Name                   -- Name of th_syn type
 665               -> MetaOps th_syn hs_syn
 666               -> RnM hs_syn
 667 runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
 668   = do  {     -- Drop the leading "$" from the quoter name, if present
 669               -- This is old-style syntax, now deprecated
 670               -- NB: when removing this backward-compat, remove
 671               --     the matching code in Lexer.x (around line 310)
 672           let occ_str = occNameString (rdrNameOcc quoter)
 673         ; quoter <- ASSERT( not (null occ_str) )  -- Lexer ensures this
 674                     if head occ_str /= '$' then return quoter
 675                     else do { addWarn (deprecatedDollar quoter)
 676                             ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }
 677
 678         ; quoter' <- lookupOccRn quoter
 679                 -- We use lookupOcc rather than lookupGlobalOcc because in the
 680                 -- erroneous case of \x -> [x| ...|] we get a better error message
 681                 -- (stage restriction rather than out of scope).
 682
 683         ; when (isUnboundName quoter') failM
 684                 -- If 'quoter' is not in scope, proceed no further
 685                 -- The error message was generated by lookupOccRn, but it then
 686                 -- succeeds with an "unbound name", which makes the subsequent
 687                 -- attempt to run the quote fail in a confusing way
 688
 689           -- Check that the quoter is not locally defined, otherwise the TH
 690           -- machinery will not be able to run the quasiquote.
 691         ; this_mod <- getModule
 692         ; let is_local = nameIsLocalOrFrom this_mod quoter'
 693         ; checkTc (not is_local) (quoteStageError quoter')
 694
 695         ; traceTc "runQQ" (ppr quoter <+> ppr is_local)
 696
 697           -- Build the expression
 698         ; let quoterExpr = L q_span $! HsVar $! quoter'
 699         ; let quoteExpr = L q_span $! HsLit $! HsString quote
 700         ; let expr = L q_span $
 701                      HsApp (L q_span $
 702                             HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
 703         ; meta_exp_ty <- tcMetaTy meta_ty
 704
 705         -- Typecheck the expression
 706         ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
 707
 708         -- Run the expression
 709         ; result <- runMetaQ meta_ops zonked_q_expr
 710         ; showSplice (mt_desc meta_ops) quoteExpr (ppr result)
 711
 712         ; return result }
 713
 714 runQuasiQuoteExpr qq = runQuasiQuote qq quoteExpName  expQTyConName  exprMetaOps
 715 runQuasiQuotePat  qq = runQuasiQuote qq quotePatName  patQTyConName  patMetaOps
 716 runQuasiQuoteType qq = runQuasiQuote qq quoteTypeName typeQTyConName typeMetaOps
 717 runQuasiQuoteDecl qq = runQuasiQuote qq quoteDecName  decsQTyConName declMetaOps
 718
 719 quoteStageError :: Name -> SDoc
 720 quoteStageError quoter
 721   = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
 722          nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
 723
 724 deprecatedDollar :: RdrName -> SDoc
 725 deprecatedDollar quoter
 726   = hang (ptext (sLit "Deprecated syntax:"))
 727        2 (ptext (sLit "quasiquotes no longer need a dollar sign:")
 728           <+> ppr quoter)
 729 \end{code}
 730
 731
 732 %************************************************************************
 733 %*                                                                      *
 734 \subsection{Running an expression}
 735 %*                                                                      *
 736 %************************************************************************
 737
 738 \begin{code}
 739 data MetaOps th_syn hs_syn
 740   = MT { mt_desc :: String             -- Type of beast (expression, type etc)
 741        , mt_show :: th_syn -> String   -- How to show the th_syn thing
 742        , mt_cvt  :: SrcSpan -> th_syn -> Either Message hs_syn
 743                                        -- How to convert to hs_syn
 744     }
 745
 746 exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName)
 747 exprMetaOps = MT { mt_desc = "expression", mt_show = TH.pprint, mt_cvt = convertToHsExpr }
 748
 749 patMetaOps :: MetaOps TH.Pat (LPat RdrName)
 750 patMetaOps = MT { mt_desc = "pattern", mt_show = TH.pprint, mt_cvt = convertToPat }
 751
 752 typeMetaOps :: MetaOps TH.Type (LHsType RdrName)
 753 typeMetaOps = MT { mt_desc = "type", mt_show = TH.pprint, mt_cvt = convertToHsType }
 754
 755 declMetaOps :: MetaOps [TH.Dec] [LHsDecl RdrName]
 756 declMetaOps = MT { mt_desc = "declarations", mt_show = TH.pprint, mt_cvt = convertToHsDecls }
 757
 758 ----------------
 759 runMetaAW :: Outputable output
 760           => (AnnotationWrapper -> output)
 761           -> LHsExpr Id         -- Of type AnnotationWrapper
 762           -> TcM output
 763 runMetaAW k = runMeta False (\_ -> return . Right . k)
 764     -- We turn off showing the code in meta-level exceptions because doing so exposes
 765     -- the toAnnotationWrapper function that we slap around the users code
 766
 767 -----------------
 768 runMetaQ :: Outputable hs_syn
 769          => MetaOps th_syn hs_syn
 770          -> LHsExpr Id
 771          -> TcM hs_syn
 772 runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
 773   = runMeta True run_and_cvt expr
 774   where
 775     run_and_cvt expr_span hval
 776        = do { th_result <- TH.runQ hval
 777             ; traceTc "Got TH result:" (text (show_th th_result))
 778             ; return (cvt expr_span th_result) }
 779
 780 runMetaE :: LHsExpr Id          -- Of type (Q Exp)
 781          -> TcM (LHsExpr RdrName)
 782 runMetaE = runMetaQ exprMetaOps
 783
 784 runMetaT :: LHsExpr Id          -- Of type (Q Type)
 785          -> TcM (LHsType RdrName)
 786 runMetaT = runMetaQ typeMetaOps
 787
 788 runMetaD :: LHsExpr Id          -- Of type Q [Dec]
 789          -> TcM [LHsDecl RdrName]
 790 runMetaD = runMetaQ declMetaOps
 791
 792 ---------------
 793 runMeta :: (Outputable hs_syn)
 794         => Bool                 -- Whether code should be printed in the exception message
 795         -> (SrcSpan -> x -> TcM (Either Message hs_syn))        -- How to run x
 796         -> LHsExpr Id           -- Of type x; typically x = Q TH.Exp, or something like that
 797         -> TcM hs_syn           -- Of type t
 798 runMeta show_code run_and_convert expr
 799   = do  { traceTc "About to run" (ppr expr)
 800
 801         -- Desugar
 802         ; ds_expr <- initDsTc (dsLExpr expr)
 803         -- Compile and link it; might fail if linking fails
 804         ; hsc_env <- getTopEnv
 805         ; src_span <- getSrcSpanM
 806         ; either_hval <- tryM $ liftIO $
 807                          HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
 808         ; case either_hval of {
 809             Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
 810             Right hval -> do
 811
 812         {       -- Coerce it to Q t, and run it
 813
 814                 -- Running might fail if it throws an exception of any kind (hence tryAllM)
 815                 -- including, say, a pattern-match exception in the code we are running
 816                 --
 817                 -- We also do the TH -> HS syntax conversion inside the same
 818                 -- exception-cacthing thing so that if there are any lurking
 819                 -- exceptions in the data structure returned by hval, we'll
 820                 -- encounter them inside the try
 821                 --
 822                 -- See Note [Exceptions in TH]
 823           let expr_span = getLoc expr
 824         ; either_tval <- tryAllM $
 825                          setSrcSpan expr_span $ -- Set the span so that qLocation can
 826                                                 -- see where this splice is
 827              do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
 828                 ; case mb_result of
 829                     Left err     -> failWithTc err
 830                     Right result -> do { traceTc "Got HsSyn result:" (ppr result)
 831                                        ; return $! result } }
 832
 833         ; case either_tval of
 834             Right v -> return v
 835             Left se -> case fromException se of
 836                          Just IOEnvFailure -> failM -- Error already in Tc monad
 837                          _ -> failWithTc (mk_msg "run" se)      -- Exception
 838         }}}
 839   where
 840     mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
 841                          nest 2 (text (Panic.showException exn)),
 842                          if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
 843 \end{code}
 844
 845 Note [Exceptions in TH]
 846 ~~~~~~~~~~~~~~~~~~~~~~~
 847 Supppose we have something like this
 848         $( f 4 )
 849 where
 850         f :: Int -> Q [Dec]
 851         f n | n>3       = fail "Too many declarations"
 852             | otherwise = ...
 853
 854 The 'fail' is a user-generated failure, and should be displayed as a
 855 perfectly ordinary compiler error message, not a panic or anything
 856 like that.  Here's how it's processed:
 857
 858   * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
 859     effectively transforms (fail s) to
 860         qReport True s >> fail
 861     where 'qReport' comes from the Quasi class and fail from its monad
 862     superclass.
 863
 864   * The TcM monad is an instance of Quasi (see TcSplice), and it implements
 865     (qReport True s) by using addErr to add an error message to the bag of errors.
 866     The 'fail' in TcM raises an IOEnvFailure exception
 867
 868   * So, when running a splice, we catch all exceptions; then for
 869         - an IOEnvFailure exception, we assume the error is already
 870                 in the error-bag (above)
 871         - other errors, we add an error to the bag
 872     and then fail
 873
 874
 875 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
 876
 877 \begin{code}
 878 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
 879   qNewName s = do { u <- newUnique
 880                   ; let i = getKey u
 881                   ; return (TH.mkNameU s i) }
 882
 883   qReport True msg  = addErr (text msg)
 884   qReport False msg = addReport (text msg) empty
 885
 886   qLocation = do { m <- getModule
 887                  ; l <- getSrcSpanM
 888                  ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
 889                                   , TH.loc_module   = moduleNameString (moduleName m)
 890                                   , TH.loc_package  = packageIdString (modulePackageId m)
 891                                   , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
 892                                   , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
 893
 894   qReify v = reify v
 895   qClassInstances = lookupClassInstances
 896
 897         -- For qRecover, discard error messages if
 898         -- the recovery action is chosen.  Otherwise
 899         -- we'll only fail higher up.  c.f. tryTcLIE_
 900   qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
 901                              ; case mb_res of
 902                                  Just val -> do { addMessages msgs      -- There might be warnings
 903                                                 ; return val }
 904                                  Nothing  -> recover                    -- Discard all msgs
 905                           }
 906
 907   qRunIO io = liftIO io
 908 \end{code}
 909
 910
 911 %************************************************************************
 912 %*                                                                      *
 913 \subsection{Errors and contexts}
 914 %*                                                                      *
 915 %************************************************************************
 916
 917 \begin{code}
 918 showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
 919 -- Note that 'before' is *renamed* but not *typechecked*
 920 -- Reason (a) less typechecking crap
 921 --        (b) data constructors after type checking have been
 922 --            changed to their *wrappers*, and that makes them
 923 --            print always fully qualified
 924 showSplice what before after
 925   = do { loc <- getSrcSpanM
 926        ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
 927                             nest 2 (sep [nest 2 (ppr before),
 928                                          text "======>",
 929                                          nest 2 after])]) }
 930
 931 illegalBracket :: SDoc
 932 illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
 933 #endif  /* GHCI */
 934 \end{code}
 935
 936
 937 %************************************************************************
 938 %*                                                                      *
 939             Instance Testing
 940 %*                                                                      *
 941 %************************************************************************
 942
 943 \begin{code}
 944 lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name]
 945 lookupClassInstances c ts
 946    = do { loc <- getSrcSpanM
 947         ; case convertToHsPred loc (TH.ClassP c ts) of {
 948             Left msg -> failWithTc msg;
 949             Right rdr_pred -> do
 950         { rn_pred <- rnLPred doc rdr_pred       -- Rename
 951         ; kc_pred <- kcHsLPred rn_pred          -- Kind check
 952         ; ClassP cls tys <- dsHsLPred kc_pred   -- Type check
 953
 954         -- Now look up instances
 955         ; inst_envs <- tcGetInstEnvs
 956         ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
 957               dfuns = map is_dfun (map fst matches ++ unifies)
 958         ; return (map reifyName dfuns) } } }
 959   where
 960     doc = ptext (sLit "TcSplice.classInstances")
 961 \end{code}
 962
 963
 964 %************************************************************************
 965 %*                                                                      *
 966                         Reification
 967 %*                                                                      *
 968 %************************************************************************
 969
 970
 971 \begin{code}
 972 reify :: TH.Name -> TcM TH.Info
 973 reify th_name
 974   = do  { name <- lookupThName th_name
 975         ; thing <- tcLookupTh name
 976                 -- ToDo: this tcLookup could fail, which would give a
 977                 --       rather unhelpful error message
 978         ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
 979         ; reifyThing thing
 980     }
 981   where
 982     ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
 983     ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
 984     ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
 985     ppr_ns _ = panic "reify/ppr_ns"
 986
 987 lookupThName :: TH.Name -> TcM Name
 988 lookupThName th_name = do
 989     mb_name <- lookupThName_maybe th_name
 990     case mb_name of
 991         Nothing   -> failWithTc (notInScope th_name)
 992         Just name -> return name
 993
 994 lookupThName_maybe th_name
 995   =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
 996           -- Pick the first that works
 997           -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
 998         ; return (listToMaybe names) }
 999   where
1000     lookup rdr_name
1001         = do {  -- Repeat much of lookupOccRn, becase we want
1002                 -- to report errors in a TH-relevant way
1003              ; rdr_env <- getLocalRdrEnv
1004              ; case lookupLocalRdrEnv rdr_env rdr_name of
1005                  Just name -> return (Just name)
1006                  Nothing   -> lookupGlobalOccRn_maybe rdr_name }
1007
1008 tcLookupTh :: Name -> TcM TcTyThing
1009 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
1010 -- it gives a reify-related error message on failure, whereas in the normal
1011 -- tcLookup, failure is a bug.
1012 tcLookupTh name
1013   = do  { (gbl_env, lcl_env) <- getEnvs
1014         ; case lookupNameEnv (tcl_env lcl_env) name of {
1015                 Just thing -> return thing;
1016                 Nothing    -> do
1017         { if nameIsLocalOrFrom (tcg_mod gbl_env) name
1018           then  -- It's defined in this module
1019               case lookupNameEnv (tcg_type_env gbl_env) name of
1020                 Just thing -> return (AGlobal thing)
1021                 Nothing    -> failWithTc (notInEnv name)
1022
1023           else do               -- It's imported
1024         { (eps,hpt) <- getEpsAndHpt
1025         ; dflags <- getDOpts
1026         ; case lookupType dflags hpt (eps_PTE eps) name of
1027             Just thing -> return (AGlobal thing)
1028             Nothing    -> do { thing <- tcImportDecl name
1029                              ; return (AGlobal thing) }
1030                 -- Imported names should always be findable;
1031                 -- if not, we fail hard in tcImportDecl
1032     }}}}
1033
1034 notInScope :: TH.Name -> SDoc
1035 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1036                      ptext (sLit "is not in scope at a reify")
1037         -- Ugh! Rather an indirect way to display the name
1038
1039 notInEnv :: Name -> SDoc
1040 notInEnv name = quotes (ppr name) <+>
1041                      ptext (sLit "is not in the type environment at a reify")
1042
1043 ------------------------------
1044 reifyThing :: TcTyThing -> TcM TH.Info
1045 -- The only reason this is monadic is for error reporting,
1046 -- which in turn is mainly for the case when TH can't express
1047 -- some random GHC extension
1048
1049 reifyThing (AGlobal (AnId id))
1050   = do  { ty <- reifyType (idType id)
1051         ; fix <- reifyFixity (idName id)
1052         ; let v = reifyName id
1053         ; case idDetails id of
1054             ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
1055             _             -> return (TH.VarI     v ty Nothing fix)
1056     }
1057
1058 reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
1059 reifyThing (AGlobal (AClass cls)) = reifyClass cls
1060 reifyThing (AGlobal (ADataCon dc))
1061   = do  { let name = dataConName dc
1062         ; ty <- reifyType (idType (dataConWrapId dc))
1063         ; fix <- reifyFixity name
1064         ; return (TH.DataConI (reifyName name) ty
1065                               (reifyName (dataConOrigTyCon dc)) fix)
1066         }
1067
1068 reifyThing (ATcId {tct_id = id})
1069   = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1070                                         -- though it may be incomplete
1071         ; ty2 <- reifyType ty1
1072         ; fix <- reifyFixity (idName id)
1073         ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
1074
1075 reifyThing (ATyVar tv ty)
1076   = do  { ty1 <- zonkTcType ty
1077         ; ty2 <- reifyType ty1
1078         ; return (TH.TyVarI (reifyName tv) ty2) }
1079
1080 reifyThing (AThing {}) = panic "reifyThing AThing"
1081
1082 ------------------------------
1083 reifyTyCon :: TyCon -> TcM TH.Info
1084 reifyTyCon tc
1085   | isFunTyCon tc
1086   = return (TH.PrimTyConI (reifyName tc) 2                False)
1087   | isPrimTyCon tc
1088   = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
1089   | isFamilyTyCon tc
1090   = let flavour = reifyFamFlavour tc
1091         tvs     = tyConTyVars tc
1092         kind    = tyConKind tc
1093         kind'
1094           | isLiftedTypeKind kind = Nothing
1095           | otherwise             = Just $ reifyKind kind
1096     in
1097     return (TH.TyConI $
1098               TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
1099   | isSynTyCon tc
1100   = do { let (tvs, rhs) = synTyConDefn tc
1101        ; rhs' <- reifyType rhs
1102        ; return (TH.TyConI $
1103                    TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
1104        }
1105
1106 reifyTyCon tc
1107   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
1108         ; let tvs = tyConTyVars tc
1109         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
1110         ; let name = reifyName tc
1111               r_tvs  = reifyTyVars tvs
1112               deriv = []        -- Don't know about deriving
1113               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1114                    | otherwise     = TH.DataD    cxt name r_tvs cons        deriv
1115         ; return (TH.TyConI decl) }
1116
1117 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
1118 -- For GADTs etc, see Note [Reifying data constructors]
1119 reifyDataCon tys dc
1120   = do { let (tvs, theta, arg_tys, _) = dataConSig dc
1121              subst             = mkTopTvSubst (tvs `zip` tys)   -- Dicard ex_tvs
1122              (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs)
1123              theta'   = substTheta subst' theta
1124              arg_tys' = substTys subst' arg_tys
1125              stricts  = map reifyStrict (dataConStrictMarks dc)
1126              fields   = dataConFieldLabels dc
1127              name     = reifyName dc
1128
1129        ; r_arg_tys <- reifyTypes arg_tys'
1130
1131        ; let main_con | not (null fields)
1132                       = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys)
1133                       | dataConIsInfix dc
1134                       = ASSERT( length arg_tys == 2 )
1135                         TH.InfixC (s1,r_a1) name (s2,r_a2)
1136                       | otherwise
1137                       = TH.NormalC name (stricts `zip` r_arg_tys)
1138              [r_a1, r_a2] = r_arg_tys
1139              [s1,   s2]   = stricts
1140
1141        ; ASSERT( length arg_tys == length stricts )
1142          if null ex_tvs' && null theta then
1143              return main_con
1144          else do
1145          { cxt <- reifyCxt theta'
1146          ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
1147
1148 ------------------------------
1149 reifyClass :: Class -> TcM TH.Info
1150 reifyClass cls
1151   = do  { cxt <- reifyCxt theta
1152         ; inst_envs <- tcGetInstEnvs
1153         ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
1154         ; ops <- mapM reify_op op_stuff
1155         ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
1156         ; return (TH.ClassI dec insts ) }
1157   where
1158     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
1159     fds' = map reifyFunDep fds
1160     reify_op (op, _) = do { ty <- reifyType (idType op)
1161                           ; return (TH.SigD (reifyName op) ty) }
1162
1163 ------------------------------
1164 reifyClassInstance :: Instance -> TcM TH.ClassInstance
1165 reifyClassInstance i
1166   = do { cxt <- reifyCxt theta
1167        ; thtypes <- reifyTypes types
1168        ; return $ (TH.ClassInstance {
1169             TH.ci_tvs = reifyTyVars tvs,
1170             TH.ci_cxt = cxt,
1171             TH.ci_tys = thtypes,
1172             TH.ci_cls = reifyName cls,
1173             TH.ci_dfun = reifyName (is_dfun i) }) }
1174   where
1175      (tvs, theta, cls, types) = instanceHead i
1176
1177 ------------------------------
1178 reifyType :: TypeRep.Type -> TcM TH.Type
1179 -- Monadic only because of failure
1180 reifyType ty@(ForAllTy _ _)        = reify_for_all ty
1181 reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty           -- Types like ((?x::Int) => Char -> Char)
1182 reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
1183 reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here
1184 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1185 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1186 reifyType ty@(PredTy {})    = pprPanic "reifyType PredTy" (ppr ty)
1187
1188 reify_for_all :: TypeRep.Type -> TcM TH.Type
1189 reify_for_all ty
1190   = do { cxt' <- reifyCxt cxt;
1191        ; tau' <- reifyType tau
1192        ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
1193   where
1194     (tvs, cxt, tau) = tcSplitSigmaTy ty
1195
1196 reifyTypes :: [Type] -> TcM [TH.Type]
1197 reifyTypes = mapM reifyType
1198
1199 reifyKind :: Kind -> TH.Kind
1200 reifyKind  ki
1201   = let (kis, ki') = splitKindFunTys ki
1202         kis_rep    = map reifyKind kis
1203         ki'_rep    = reifyNonArrowKind ki'
1204     in
1205     foldr TH.ArrowK ki'_rep kis_rep
1206   where
1207     reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
1208                         | otherwise          = pprPanic "Exotic form of kind"
1209                                                         (ppr k)
1210
1211 reifyCxt :: [PredType] -> TcM [TH.Pred]
1212 reifyCxt   = mapM reifyPred
1213
1214 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1215 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1216
1217 reifyFamFlavour :: TyCon -> TH.FamFlavour
1218 reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
1219                    | isFamilyTyCon    tc = TH.DataFam
1220                    | otherwise
1221                    = panic "TcSplice.reifyFamFlavour: not a type family"
1222
1223 reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
1224 reifyTyVars = map reifyTyVar
1225   where
1226     reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
1227                   | otherwise             = TH.KindedTV name (reifyKind kind)
1228       where
1229         kind = tyVarKind tv
1230         name = reifyName tv
1231
1232 reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
1233 reify_tc_app tc tys
1234   = do { tys' <- reifyTypes tys
1235        ; return (foldl TH.AppT r_tc tys') }
1236   where
1237     n_tys = length tys
1238     r_tc | isTupleTyCon tc          = TH.TupleT n_tys
1239          | tc `hasKey` listTyConKey = TH.ListT
1240          | otherwise                = TH.ConT (reifyName tc)
1241
1242 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1243 reifyPred (ClassP cls tys)
1244   = do { tys' <- reifyTypes tys
1245        ; return $ TH.ClassP (reifyName cls) tys' }
1246
1247 reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
1248 reifyPred (EqPred ty1 ty2)
1249   = do { ty1' <- reifyType ty1
1250        ; ty2' <- reifyType ty2
1251        ; return $ TH.EqualP ty1' ty2'
1252        }
1253
1254
1255 ------------------------------
1256 reifyName :: NamedThing n => n -> TH.Name
1257 reifyName thing
1258   | isExternalName name = mk_varg pkg_str mod_str occ_str
1259   | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
1260         -- Many of the things we reify have local bindings, and
1261         -- NameL's aren't supposed to appear in binding positions, so
1262         -- we use NameU.  When/if we start to reify nested things, that
1263         -- have free variables, we may need to generate NameL's for them.
1264   where
1265     name    = getName thing
1266     mod     = ASSERT( isExternalName name ) nameModule name
1267     pkg_str = packageIdString (modulePackageId mod)
1268     mod_str = moduleNameString (moduleName mod)
1269     occ_str = occNameString occ
1270     occ     = nameOccName name
1271     mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1272             | OccName.isVarOcc  occ = TH.mkNameG_v
1273             | OccName.isTcOcc   occ = TH.mkNameG_tc
1274             | otherwise             = pprPanic "reifyName" (ppr name)
1275
1276 ------------------------------
1277 reifyFixity :: Name -> TcM TH.Fixity
1278 reifyFixity name
1279   = do  { fix <- lookupFixityRn name
1280         ; return (conv_fix fix) }
1281     where
1282       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1283       conv_dir BasicTypes.InfixR = TH.InfixR
1284       conv_dir BasicTypes.InfixL = TH.InfixL
1285       conv_dir BasicTypes.InfixN = TH.InfixN
1286
1287 reifyStrict :: BasicTypes.HsBang -> TH.Strict
1288 reifyStrict bang | isBanged bang = TH.IsStrict
1289                  | otherwise     = TH.NotStrict
1290
1291 ------------------------------
1292 noTH :: LitString -> SDoc -> TcM a
1293 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1294                                 ptext (sLit "in Template Haskell:"),
1295                              nest 2 d])
1296 \end{code}
1297
1298 Note [Reifying data constructors]
1299 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1300 Template Haskell syntax is rich enough to express even GADTs,
1301 provided we do so in the equality-predicate form.  So a GADT
1302 like
1303
1304   data T a where
1305      MkT1 :: a -> T [a]
1306      MkT2 :: T Int
1307
1308 will appear in TH syntax like this
1309
1310   data T a = forall b. (a ~ [b]) => MkT1 b
1311            | (a ~ Int) => MkT2
1312