compiler/typecheck/TcSplice.lhs

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