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