compiler/typecheck/TcSplice.lhs

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