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