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