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 -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where
  17
  18 #include "HsVersions.h"
  19
  20 import HscMain
  21 import TcRnDriver
  22         -- These imports are the reason that TcSplice
  23         -- is very high up the module hierarchy
  24
  25 import HsSyn
  26 import Convert
  27 import RnExpr
  28 import RnEnv
  29 import RdrName
  30 import RnTypes
  31 import TcExpr
  32 import TcHsSyn
  33 import TcSimplify
  34 import TcUnify
  35 import TcType
  36 import TcEnv
  37 import TcMType
  38 import TcHsType
  39 import TcIface
  40 import TypeRep
  41 import Name
  42 import NameEnv
  43 import HscTypes
  44 import OccName
  45 import Var
  46 import Module
  47 import TcRnMonad
  48 import IfaceEnv
  49 import Class
  50 import TyCon
  51 import DataCon
  52 import Id
  53 import IdInfo
  54 import TysWiredIn
  55 import DsMeta
  56 import DsExpr
  57 import DsMonad hiding (Splice)
  58 import ErrUtils
  59 import SrcLoc
  60 import Outputable
  61 import Unique
  62 import DynFlags
  63 import PackageConfig
  64 import Maybe
  65 import BasicTypes
  66 import Panic
  67 import FastString
  68
  69 import qualified Language.Haskell.TH as TH
  70 -- THSyntax gives access to internal functions and data types
  71 import qualified Language.Haskell.TH.Syntax as TH
  72
  73 import GHC.Exts         ( unsafeCoerce#, Int#, Int(..) )
  74 import Control.Monad    ( liftM )
  75 import qualified Control.Exception  as Exception( userErrors )
  76 \end{code}
  77
  78 Note [Template Haskell levels]
  79 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  80 * Imported things are impLevel (= 0)
  81 * Variables are bound at the "current level"
  82 * The current level starts off at topLevel (= 1)
  83 * The level is decremented by splicing $(..)
  84                incremented by brackets [| |]
  85                incremented by name-quoting 'f
  86
  87 When a variable is used, we compare
  88         bind:  binding level, and
  89         use:   current level at usage site
  90
  91   Generally
  92         bind > use      Always error (bound later than used)
  93                         [| \x -> $(f x) |]
  94
  95         bind = use      Always OK (bound same stage as used)
  96                         [| \x -> $(f [| x |]) |]
  97
  98         bind < use      Inside brackets, it depends
  99                         Inside splice, OK
 100                         Inside neither, OK
 101
 102   For (bind < use) inside brackets, there are three cases:
 103     - Imported things   OK      f = [| map |]
 104     - Top-level things  OK      g = [| f |]
 105     - Non-top-level     Only if there is a liftable instance
 106                                 h = \(x:Int) -> [| x |]
 107
 108 Note [Quoting names]
 109 ~~~~~~~~~~~~~~~~~~~~
 110 A quoted name is a bit like a quoted expression, except that we have no
 111 cross-stage lifting (c.f. TcExpr.thBrackId).
 112
 113 Examples:
 114
 115   f 'map        -- OK; also for top-level defns of this module
 116
 117   \x. f 'x      -- Not ok (whereas \x. f [| x |] might have been ok, by
 118                 --                               cross-stage lifting
 119
 120   \y. [| \x. $(f 'y) |] -- Not ok (same reason)
 121
 122   [| \x. $(f 'x) |]     -- OK
 123
 124
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection{Main interface + stubs for the non-GHCI case
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 \begin{code}
 133 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 134 tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
 135 kcSpliceType  :: HsSplice Name -> TcM (HsType Name, TcKind)
 136         -- None of these functions add constraints to the LIE
 137
 138 #ifndef GHCI
 139 tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
 140 tcSpliceDecls e     = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
 141 #else
 142 \end{code}
 143
 144 %************************************************************************
 145 %*                                                                      *
 146 \subsection{Quoting an expression}
 147 %*                                                                      *
 148 %************************************************************************
 149
 150 Note [Handling brackets]
 151 ~~~~~~~~~~~~~~~~~~~~~~~~
 152 Source:         f = [| Just $(g 3) |]
 153   The [| |] part is a HsBracket
 154
 155 Typechecked:    f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
 156   The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
 157   The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
 158
 159 Desugared:      f = do { s7 <- g Int 3
 160                        ; return (ConE "Data.Maybe.Just" s7) }
 161
 162 \begin{code}
 163 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 164 tcBracket brack res_ty
 165   = getStage                            `thenM` \ level ->
 166     case bracketOK level of {
 167         Nothing         -> failWithTc (illegalBracket level) ;
 168         Just next_level ->
 169
 170         -- Typecheck expr to make sure it is valid,
 171         -- but throw away the results.  We'll type check
 172         -- it again when we actually use it.
 173     recordThUse                         `thenM_`
 174     newMutVar []                        `thenM` \ pending_splices ->
 175     getLIEVar                           `thenM` \ lie_var ->
 176
 177     setStage (Brack next_level pending_splices lie_var) (
 178         getLIE (tc_bracket brack)
 179     )                                   `thenM` \ (meta_ty, lie) ->
 180     tcSimplifyBracket lie               `thenM_`
 181
 182         -- Make the expected type have the right shape
 183     boxyUnify meta_ty res_ty            `thenM_`
 184
 185         -- Return the original expression, not the type-decorated one
 186     readMutVar pending_splices          `thenM` \ pendings ->
 187     returnM (noLoc (HsBracketOut brack pendings))
 188     }
 189
 190 tc_bracket :: HsBracket Name -> TcM TcType
 191 tc_bracket (VarBr name)         -- Note [Quoting names]
 192   = do  { thing <- tcLookup name
 193         ; case thing of
 194             AGlobal _ -> return ()
 195             ATcId { tct_level = bind_lvl }
 196                 | isExternalName name   -- C.f isExternalName case of
 197                 -> keepAliveTc name     --     TcExpr.thBrackId
 198                 | otherwise
 199                 -> do { use_stage <- getStage
 200                       ; checkTc (thLevel use_stage == bind_lvl)
 201                                 (quotedNameStageErr name) }
 202             other -> pprPanic "th_bracket" (ppr name)
 203
 204         ; tcMetaTy nameTyConName        -- Result type is Var (not Q-monadic)
 205         }
 206
 207 tc_bracket (ExpBr expr)
 208   = do  { any_ty <- newFlexiTyVarTy liftedTypeKind
 209         ; tcMonoExpr expr any_ty
 210         ; tcMetaTy expQTyConName }
 211         -- Result type is Expr (= Q Exp)
 212
 213 tc_bracket (TypBr typ)
 214   = do  { tcHsSigType ExprSigCtxt typ
 215         ; tcMetaTy typeQTyConName }
 216         -- Result type is Type (= Q Typ)
 217
 218 tc_bracket (DecBr decls)
 219   = do  {  tcTopSrcDecls emptyModDetails decls
 220         -- Typecheck the declarations, dicarding the result
 221         -- We'll get all that stuff later, when we splice it in
 222
 223         ; decl_ty <- tcMetaTy decTyConName
 224         ; q_ty    <- tcMetaTy qTyConName
 225         ; return (mkAppTy q_ty (mkListTy decl_ty))
 226         -- Result type is Q [Dec]
 227     }
 228
 229 tc_bracket (PatBr _)
 230   = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
 231
 232 quotedNameStageErr v
 233   = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
 234         , ptext SLIT("must be used at the same stage at which is is bound")]
 235 \end{code}
 236
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection{Splicing an expression}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 \begin{code}
 245 tcSpliceExpr (HsSplice name expr) res_ty
 246   = setSrcSpan (getLoc expr)    $
 247     getStage            `thenM` \ level ->
 248     case spliceOK level of {
 249         Nothing         -> failWithTc (illegalSplice level) ;
 250         Just next_level ->
 251
 252     case level of {
 253         Comp                   -> do { e <- tcTopSplice expr res_ty
 254                                      ; returnM (unLoc e) } ;
 255         Brack _ ps_var lie_var ->
 256
 257         -- A splice inside brackets
 258         -- NB: ignore res_ty, apart from zapping it to a mono-type
 259         -- e.g.   [| reverse $(h 4) |]
 260         -- Here (h 4) :: Q Exp
 261         -- but $(h 4) :: forall a.a     i.e. anything!
 262
 263     unBox res_ty                                `thenM_`
 264     tcMetaTy expQTyConName                      `thenM` \ meta_exp_ty ->
 265     setStage (Splice next_level) (
 266         setLIEVar lie_var          $
 267         tcMonoExpr expr meta_exp_ty
 268     )                                           `thenM` \ expr' ->
 269
 270         -- Write the pending splice into the bucket
 271     readMutVar ps_var                           `thenM` \ ps ->
 272     writeMutVar ps_var ((name,expr') : ps)      `thenM_`
 273
 274     returnM (panic "tcSpliceExpr")      -- The returned expression is ignored
 275     }}
 276
 277 -- tcTopSplice used to have this:
 278 -- Note that we do not decrement the level (to -1) before
 279 -- typechecking the expression.  For example:
 280 --      f x = $( ...$(g 3) ... )
 281 -- The recursive call to tcMonoExpr will simply expand the
 282 -- inner escape before dealing with the outer one
 283
 284 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
 285 tcTopSplice expr res_ty
 286   = tcMetaTy expQTyConName              `thenM` \ meta_exp_ty ->
 287
 288         -- Typecheck the expression
 289     tcTopSpliceExpr expr meta_exp_ty    `thenM` \ zonked_q_expr ->
 290
 291         -- Run the expression
 292     traceTc (text "About to run" <+> ppr zonked_q_expr)         `thenM_`
 293     runMetaE convertToHsExpr zonked_q_expr      `thenM` \ expr2 ->
 294
 295     traceTc (text "Got result" <+> ppr expr2)   `thenM_`
 296
 297     showSplice "expression"
 298                zonked_q_expr (ppr expr2)        `thenM_`
 299
 300         -- Rename it, but bale out if there are errors
 301         -- otherwise the type checker just gives more spurious errors
 302     checkNoErrs (rnLExpr expr2)                 `thenM` \ (exp3, fvs) ->
 303
 304     tcMonoExpr exp3 res_ty
 305
 306
 307 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
 308 -- Type check an expression that is the body of a top-level splice
 309 --   (the caller will compile and run it)
 310 tcTopSpliceExpr expr meta_ty
 311   = checkNoErrs $       -- checkNoErrs: must not try to run the thing
 312                         --              if the type checker fails!
 313
 314     setStage topSpliceStage $ do
 315
 316
 317     do  { recordThUse   -- Record that TH is used (for pkg depdendency)
 318
 319         -- Typecheck the expression
 320         ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
 321
 322         -- Solve the constraints
 323         ; const_binds <- tcSimplifyTop lie
 324
 325         -- And zonk it
 326         ; zonkTopLExpr (mkHsDictLet const_binds expr') }
 327 \end{code}
 328
 329
 330 %************************************************************************
 331 %*                                                                      *
 332                 Splicing a type
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 Very like splicing an expression, but we don't yet share code.
 337
 338 \begin{code}
 339 kcSpliceType (HsSplice name hs_expr)
 340   = setSrcSpan (getLoc hs_expr) $ do
 341         { level <- getStage
 342         ; case spliceOK level of {
 343                 Nothing         -> failWithTc (illegalSplice level) ;
 344                 Just next_level -> do
 345
 346         { case level of {
 347                 Comp                   -> do { (t,k) <- kcTopSpliceType hs_expr
 348                                              ; return (unLoc t, k) } ;
 349                 Brack _ ps_var lie_var -> do
 350
 351         {       -- A splice inside brackets
 352         ; meta_ty <- tcMetaTy typeQTyConName
 353         ; expr' <- setStage (Splice next_level) $
 354                    setLIEVar lie_var            $
 355                    tcMonoExpr hs_expr meta_ty
 356
 357                 -- Write the pending splice into the bucket
 358         ; ps <- readMutVar ps_var
 359         ; writeMutVar ps_var ((name,expr') : ps)
 360
 361         -- e.g.   [| Int -> $(h 4) |]
 362         -- Here (h 4) :: Q Type
 363         -- but $(h 4) :: forall a.a     i.e. any kind
 364         ; kind <- newKindVar
 365         ; returnM (panic "kcSpliceType", kind)  -- The returned type is ignored
 366     }}}}}
 367
 368 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
 369 kcTopSpliceType expr
 370   = do  { meta_ty <- tcMetaTy typeQTyConName
 371
 372         -- Typecheck the expression
 373         ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
 374
 375         -- Run the expression
 376         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 377         ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
 378
 379         ; traceTc (text "Got result" <+> ppr hs_ty2)
 380
 381         ; showSplice "type" zonked_q_expr (ppr hs_ty2)
 382
 383         -- Rename it, but bale out if there are errors
 384         -- otherwise the type checker just gives more spurious errors
 385         ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
 386         ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
 387
 388         ; kcHsType hs_ty3 }
 389 \end{code}
 390
 391 %************************************************************************
 392 %*                                                                      *
 393 \subsection{Splicing an expression}
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 \begin{code}
 398 -- Always at top level
 399 -- Type sig at top of file:
 400 --      tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 401 tcSpliceDecls expr
 402   = do  { meta_dec_ty <- tcMetaTy decTyConName
 403         ; meta_q_ty <- tcMetaTy qTyConName
 404         ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
 405         ; zonked_q_expr <- tcTopSpliceExpr expr list_q
 406
 407                 -- Run the expression
 408         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 409         ; decls <- runMetaD convertToHsDecls zonked_q_expr
 410
 411         ; traceTc (text "Got result" <+> vcat (map ppr decls))
 412         ; showSplice "declarations"
 413                      zonked_q_expr
 414                      (ppr (getLoc expr) $$ (vcat (map ppr decls)))
 415         ; returnM decls }
 416
 417   where handleErrors :: [Either a Message] -> TcM [a]
 418         handleErrors [] = return []
 419         handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
 420         handleErrors (Right m:xs) = do addErrTc m
 421                                        handleErrors xs
 422 \end{code}
 423
 424
 425 %************************************************************************
 426 %*                                                                      *
 427 \subsection{Running an expression}
 428 %*                                                                      *
 429 %************************************************************************
 430
 431 \begin{code}
 432 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
 433          -> LHsExpr Id          -- Of type (Q Exp)
 434          -> TcM (LHsExpr RdrName)
 435 runMetaE  = runMeta
 436
 437 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
 438          -> LHsExpr Id          -- Of type (Q Type)
 439          -> TcM (LHsType RdrName)
 440 runMetaT = runMeta
 441
 442 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
 443          -> LHsExpr Id          -- Of type Q [Dec]
 444          -> TcM [LHsDecl RdrName]
 445 runMetaD = runMeta
 446
 447 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
 448         -> LHsExpr Id           -- Of type X
 449         -> TcM hs_syn           -- Of type t
 450 runMeta convert expr
 451   = do  {       -- Desugar
 452           ds_expr <- initDsTc (dsLExpr expr)
 453         -- Compile and link it; might fail if linking fails
 454         ; hsc_env <- getTopEnv
 455         ; src_span <- getSrcSpanM
 456         ; either_hval <- tryM $ ioToTcRn $
 457                          HscMain.compileExpr hsc_env src_span ds_expr
 458         ; case either_hval of {
 459             Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
 460             Right hval -> do
 461
 462         {       -- Coerce it to Q t, and run it
 463
 464                 -- Running might fail if it throws an exception of any kind (hence tryAllM)
 465                 -- including, say, a pattern-match exception in the code we are running
 466                 --
 467                 -- We also do the TH -> HS syntax conversion inside the same
 468                 -- exception-cacthing thing so that if there are any lurking
 469                 -- exceptions in the data structure returned by hval, we'll
 470                 -- encounter them inside the try
 471                 --
 472                 -- See Note [Exceptions in TH]
 473           either_tval <- tryAllM $ do
 474                 { th_syn <- TH.runQ (unsafeCoerce# hval)
 475                 ; case convert (getLoc expr) th_syn of
 476                     Left err     -> failWithTc err
 477                     Right hs_syn -> return hs_syn }
 478
 479         ; case either_tval of
 480             Right v -> return v
 481             Left exn | Just s <- Exception.userErrors exn
 482                      , s == "IOEnv failure"
 483                      -> failM   -- Error already in Tc monad
 484                      | otherwise -> failWithTc (mk_msg "run" exn)       -- Exception
 485         }}}
 486   where
 487     mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
 488                          nest 2 (text (Panic.showException exn)),
 489                          nest 2 (text "Code:" <+> ppr expr)]
 490 \end{code}
 491
 492 Note [Exceptions in TH]
 493 ~~~~~~~~~~~~~~~~~~~~~~~
 494 Supppose we have something like this
 495         $( f 4 )
 496 where
 497         f :: Int -> Q [Dec]
 498         f n | n>3       = fail "Too many declarations"
 499             | otherwise = ...
 500
 501 The 'fail' is a user-generated failure, and should be displayed as a
 502 perfectly ordinary compiler error message, not a panic or anything
 503 like that.  Here's how it's processed:
 504
 505   * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
 506     effectively transforms (fail s) to
 507         qReport True s >> fail
 508     where 'qReport' comes from the Quasi class and fail from its monad
 509     superclass.
 510
 511   * The TcM monad is an instance of Quasi (see TcSplice), and it implements
 512     (qReport True s) by using addErr to add an error message to the bag of errors.
 513     The 'fail' in TcM raises a UserError, with the uninteresting string
 514         "IOEnv failure"
 515
 516   * So, when running a splice, we catch all exceptions; then for
 517         - a UserError "IOEnv failure", we assume the error is already
 518                 in the error-bag (above)
 519         - other errors, we add an error to the bag
 520     and then fail
 521
 522
 523 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
 524
 525 \begin{code}
 526 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
 527   qNewName s = do { u <- newUnique
 528                   ; let i = getKey u
 529                   ; return (TH.mkNameU s i) }
 530
 531   qReport True msg  = addErr (text msg)
 532   qReport False msg = addReport (text msg)
 533
 534   qCurrentModule = do { m <- getModule;
 535                         return (moduleNameString (moduleName m)) }
 536                 -- ToDo: is throwing away the package name ok here?
 537
 538   qReify v = reify v
 539
 540         -- For qRecover, discard error messages if
 541         -- the recovery action is chosen.  Otherwise
 542         -- we'll only fail higher up.  c.f. tryTcLIE_
 543   qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
 544                              ; case mb_res of
 545                                  Just val -> do { addMessages msgs      -- There might be warnings
 546                                                 ; return val }
 547                                  Nothing  -> recover                    -- Discard all msgs
 548                           }
 549
 550   qRunIO io = ioToTcRn io
 551 \end{code}
 552
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsection{Errors and contexts}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 \begin{code}
 561 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
 562 showSplice what before after
 563   = getSrcSpanM         `thenM` \ loc ->
 564     traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
 565                        nest 2 (sep [nest 2 (ppr before),
 566                                     text "======>",
 567                                     nest 2 after])])
 568
 569 illegalBracket level
 570   = ptext SLIT("Illegal bracket at level") <+> ppr level
 571
 572 illegalSplice level
 573   = ptext SLIT("Illegal splice at level") <+> ppr level
 574
 575 #endif  /* GHCI */
 576 \end{code}
 577
 578
 579 %************************************************************************
 580 %*                                                                      *
 581                         Reification
 582 %*                                                                      *
 583 %************************************************************************
 584
 585
 586 \begin{code}
 587 reify :: TH.Name -> TcM TH.Info
 588 reify th_name
 589   = do  { name <- lookupThName th_name
 590         ; thing <- tcLookupTh name
 591                 -- ToDo: this tcLookup could fail, which would give a
 592                 --       rather unhelpful error message
 593         ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
 594         ; reifyThing thing
 595     }
 596   where
 597     ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
 598     ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
 599     ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
 600
 601 lookupThName :: TH.Name -> TcM Name
 602 lookupThName th_name@(TH.Name occ flavour)
 603   =  do { let rdr_name = thRdrName guessed_ns occ_str flavour
 604
 605         -- Repeat much of lookupOccRn, becase we want
 606         -- to report errors in a TH-relevant way
 607         ; rdr_env <- getLocalRdrEnv
 608         ; case lookupLocalRdrEnv rdr_env rdr_name of
 609             Just name -> return name
 610             Nothing | not (isSrcRdrName rdr_name)       -- Exact, Orig
 611                     -> lookupImportedName rdr_name
 612                     | otherwise                         -- Unqual, Qual
 613                     -> do { mb_name <- lookupSrcOcc_maybe rdr_name
 614                           ; case mb_name of
 615                               Just name -> return name
 616                               Nothing   -> failWithTc (notInScope th_name) }
 617         }
 618   where
 619         -- guessed_ns is the name space guessed from looking at the TH name
 620     guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
 621                | otherwise                       = OccName.varName
 622     occ_str = TH.occString occ
 623
 624 tcLookupTh :: Name -> TcM TcTyThing
 625 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
 626 -- it gives a reify-related error message on failure, whereas in the normal
 627 -- tcLookup, failure is a bug.
 628 tcLookupTh name
 629   = do  { (gbl_env, lcl_env) <- getEnvs
 630         ; case lookupNameEnv (tcl_env lcl_env) name of {
 631                 Just thing -> returnM thing;
 632                 Nothing    -> do
 633         { if nameIsLocalOrFrom (tcg_mod gbl_env) name
 634           then  -- It's defined in this module
 635               case lookupNameEnv (tcg_type_env gbl_env) name of
 636                 Just thing -> return (AGlobal thing)
 637                 Nothing    -> failWithTc (notInEnv name)
 638
 639           else do               -- It's imported
 640         { (eps,hpt) <- getEpsAndHpt
 641         ; dflags <- getDOpts
 642         ; case lookupType dflags hpt (eps_PTE eps) name of
 643             Just thing -> return (AGlobal thing)
 644             Nothing    -> do { thing <- tcImportDecl name
 645                              ; return (AGlobal thing) }
 646                 -- Imported names should always be findable;
 647                 -- if not, we fail hard in tcImportDecl
 648     }}}}
 649
 650 notInScope :: TH.Name -> SDoc
 651 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
 652                      ptext SLIT("is not in scope at a reify")
 653         -- Ugh! Rather an indirect way to display the name
 654
 655 notInEnv :: Name -> SDoc
 656 notInEnv name = quotes (ppr name) <+>
 657                      ptext SLIT("is not in the type environment at a reify")
 658
 659 ------------------------------
 660 reifyThing :: TcTyThing -> TcM TH.Info
 661 -- The only reason this is monadic is for error reporting,
 662 -- which in turn is mainly for the case when TH can't express
 663 -- some random GHC extension
 664
 665 reifyThing (AGlobal (AnId id))
 666   = do  { ty <- reifyType (idType id)
 667         ; fix <- reifyFixity (idName id)
 668         ; let v = reifyName id
 669         ; case globalIdDetails id of
 670             ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
 671             other            -> return (TH.VarI     v ty Nothing fix)
 672     }
 673
 674 reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
 675 reifyThing (AGlobal (AClass cls)) = reifyClass cls
 676 reifyThing (AGlobal (ADataCon dc))
 677   = do  { let name = dataConName dc
 678         ; ty <- reifyType (idType (dataConWrapId dc))
 679         ; fix <- reifyFixity name
 680         ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
 681
 682 reifyThing (ATcId {tct_id = id, tct_type = ty})
 683   = do  { ty1 <- zonkTcType ty  -- Make use of all the info we have, even
 684                                 -- though it may be incomplete
 685         ; ty2 <- reifyType ty1
 686         ; fix <- reifyFixity (idName id)
 687         ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
 688
 689 reifyThing (ATyVar tv ty)
 690   = do  { ty1 <- zonkTcType ty
 691         ; ty2 <- reifyType ty1
 692         ; return (TH.TyVarI (reifyName tv) ty2) }
 693
 694 ------------------------------
 695 reifyTyCon :: TyCon -> TcM TH.Info
 696 reifyTyCon tc
 697   | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2               False)
 698   | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
 699   | isSynTyCon tc
 700   = do { let (tvs, rhs) = synTyConDefn tc
 701        ; rhs' <- reifyType rhs
 702        ; return (TH.TyConI $
 703                    TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 704
 705 reifyTyCon tc
 706   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
 707         ; let tvs = tyConTyVars tc
 708         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
 709         ; let name = reifyName tc
 710               r_tvs  = reifyTyVars tvs
 711               deriv = []        -- Don't know about deriving
 712               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
 713                    | otherwise     = TH.DataD    cxt name r_tvs cons      deriv
 714         ; return (TH.TyConI decl) }
 715
 716 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
 717 reifyDataCon tys dc
 718   | isVanillaDataCon dc
 719   = do  { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
 720         ; let stricts = map reifyStrict (dataConStrictMarks dc)
 721               fields  = dataConFieldLabels dc
 722               name    = reifyName dc
 723               [a1,a2] = arg_tys
 724               [s1,s2] = stricts
 725         ; ASSERT( length arg_tys == length stricts )
 726           if not (null fields) then
 727              return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
 728           else
 729           if dataConIsInfix dc then
 730              ASSERT( length arg_tys == 2 )
 731              return (TH.InfixC (s1,a1) name (s2,a2))
 732           else
 733              return (TH.NormalC name (stricts `zip` arg_tys)) }
 734   | otherwise
 735   = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:")
 736                 <+> quotes (ppr dc))
 737
 738 ------------------------------
 739 reifyClass :: Class -> TcM TH.Info
 740 reifyClass cls
 741   = do  { cxt <- reifyCxt theta
 742         ; ops <- mapM reify_op op_stuff
 743         ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
 744   where
 745     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
 746     fds' = map reifyFunDep fds
 747     reify_op (op, _) = do { ty <- reifyType (idType op)
 748                           ; return (TH.SigD (reifyName op) ty) }
 749
 750 ------------------------------
 751 reifyType :: TypeRep.Type -> TcM TH.Type
 752 reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
 753 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
 754 reifyType (NoteTy _ ty)     = reifyType ty
 755 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
 756 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
 757 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
 758                                  ; tau' <- reifyType tau
 759                                  ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
 760                             where
 761                                 (tvs, cxt, tau) = tcSplitSigmaTy ty
 762 reifyTypes = mapM reifyType
 763 reifyCxt   = mapM reifyPred
 764
 765 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
 766 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
 767
 768 reifyTyVars :: [TyVar] -> [TH.Name]
 769 reifyTyVars = map reifyName
 770
 771 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 772 reify_tc_app tc tys = do { tys' <- reifyTypes tys
 773                          ; return (foldl TH.AppT (TH.ConT tc) tys') }
 774
 775 reifyPred :: TypeRep.PredType -> TcM TH.Type
 776 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
 777 reifyPred p@(IParam _ _)   = noTH SLIT("implicit parameters") (ppr p)
 778
 779
 780 ------------------------------
 781 reifyName :: NamedThing n => n -> TH.Name
 782 reifyName thing
 783   | isExternalName name = mk_varg pkg_str mod_str occ_str
 784   | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
 785         -- Many of the things we reify have local bindings, and
 786         -- NameL's aren't supposed to appear in binding positions, so
 787         -- we use NameU.  When/if we start to reify nested things, that
 788         -- have free variables, we may need to generate NameL's for them.
 789   where
 790     name    = getName thing
 791     mod     = nameModule name
 792     pkg_str = packageIdString (modulePackageId mod)
 793     mod_str = moduleNameString (moduleName mod)
 794     occ_str = occNameString occ
 795     occ     = nameOccName name
 796     mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
 797             | OccName.isVarOcc  occ = TH.mkNameG_v
 798             | OccName.isTcOcc   occ = TH.mkNameG_tc
 799             | otherwise             = pprPanic "reifyName" (ppr name)
 800
 801 ------------------------------
 802 reifyFixity :: Name -> TcM TH.Fixity
 803 reifyFixity name
 804   = do  { fix <- lookupFixityRn name
 805         ; return (conv_fix fix) }
 806     where
 807       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
 808       conv_dir BasicTypes.InfixR = TH.InfixR
 809       conv_dir BasicTypes.InfixL = TH.InfixL
 810       conv_dir BasicTypes.InfixN = TH.InfixN
 811
 812 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
 813 reifyStrict MarkedStrict    = TH.IsStrict
 814 reifyStrict MarkedUnboxed   = TH.IsStrict
 815 reifyStrict NotMarkedStrict = TH.NotStrict
 816
 817 ------------------------------
 818 noTH :: LitString -> SDoc -> TcM a
 819 noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
 820                                 ptext SLIT("in Template Haskell:"),
 821                              nest 2 d])
 822 \end{code}