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