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