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