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