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