ghc/compiler/typecheck/TcSplice.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcSplice]{Template Haskell splices}
   5
   6 \begin{code}
   7 module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HscMain          ( compileExpr )
  12 import TcRnDriver       ( tcTopSrcDecls )
  13         -- These imports are the reason that TcSplice
  14         -- is very high up the module hierarchy
  15
  16 import qualified Language.Haskell.TH as TH
  17 -- THSyntax gives access to internal functions and data types
  18 import qualified Language.Haskell.TH.Syntax as TH
  19
  20 import HsSyn            ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl,
  21                           HsType, LHsType )
  22 import Convert          ( convertToHsExpr, convertToHsDecls, convertToHsType )
  23 import RnExpr           ( rnLExpr )
  24 import RnEnv            ( lookupFixityRn, lookupSrcOcc_maybe )
  25 import RdrName          ( RdrName, mkRdrUnqual, lookupLocalRdrEnv )
  26 import RnTypes          ( rnLHsType )
  27 import TcExpr           ( tcCheckRho, tcMonoExpr )
  28 import TcHsSyn          ( mkHsLet, zonkTopLExpr )
  29 import TcSimplify       ( tcSimplifyTop, tcSimplifyBracket )
  30 import TcUnify          ( Expected, zapExpectedTo, zapExpectedType )
  31 import TcType           ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
  32 import TcEnv            ( spliceOK, tcMetaTy, bracketOK )
  33 import TcMType          ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
  34 import TcHsType         ( tcHsSigType, kcHsType )
  35 import TcIface          ( tcImportDecl )
  36 import TypeRep          ( Type(..), PredType(..), TyThing(..) ) -- For reification
  37 import Name             ( Name, NamedThing(..), nameOccName, nameModule, isExternalName,
  38                           mkInternalName, nameIsLocalOrFrom )
  39 import NameEnv          ( lookupNameEnv )
  40 import HscTypes         ( lookupType, ExternalPackageState(..) )
  41 import OccName
  42 import Var              ( Id, TyVar, idType )
  43 import Module           ( moduleUserString, mkModuleName )
  44 import TcRnMonad
  45 import IfaceEnv         ( lookupOrig )
  46 import Class            ( Class, classBigSig )
  47 import TyCon            ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons )
  48 import DataCon          ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
  49                           dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix )
  50 import Id               ( idName, globalIdDetails )
  51 import IdInfo           ( GlobalIdDetails(..) )
  52 import TysWiredIn       ( mkListTy )
  53 import DsMeta           ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
  54 import ErrUtils         ( Message )
  55 import SrcLoc           ( noLoc, unLoc, getLoc, noSrcLoc )
  56 import Outputable
  57 import Unique           ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
  58
  59 import BasicTypes       ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
  60 import Panic            ( showException )
  61 import FastString       ( LitString )
  62
  63 import GHC.Base         ( unsafeCoerce#, Int#, Int(..) )        -- Should have a better home in the module hierarchy
  64 import Monad            ( liftM )
  65
  66 #ifdef GHCI
  67 import FastString       ( mkFastString )
  68 #endif
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{Main interface + stubs for the non-GHCI case
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
  80 tcSpliceExpr  :: HsSplice Name -> Expected TcType -> TcM (HsExpr TcId)
  81 kcSpliceType  :: HsSplice Name -> TcM (HsType Name, TcKind)
  82
  83 #ifndef GHCI
  84 tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
  85 tcSpliceDecls e     = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
  86 #else
  87 \end{code}
  88
  89 %************************************************************************
  90 %*                                                                      *
  91 \subsection{Quoting an expression}
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 \begin{code}
  96 tcBracket :: HsBracket Name -> Expected TcType -> TcM (LHsExpr Id)
  97 tcBracket brack res_ty
  98   = getStage                            `thenM` \ level ->
  99     case bracketOK level of {
 100         Nothing         -> failWithTc (illegalBracket level) ;
 101         Just next_level ->
 102
 103         -- Typecheck expr to make sure it is valid,
 104         -- but throw away the results.  We'll type check
 105         -- it again when we actually use it.
 106     recordThUse                         `thenM_`
 107     newMutVar []                        `thenM` \ pending_splices ->
 108     getLIEVar                           `thenM` \ lie_var ->
 109
 110     setStage (Brack next_level pending_splices lie_var) (
 111         getLIE (tc_bracket brack)
 112     )                                   `thenM` \ (meta_ty, lie) ->
 113     tcSimplifyBracket lie               `thenM_`
 114
 115         -- Make the expected type have the right shape
 116     zapExpectedTo res_ty meta_ty        `thenM_`
 117
 118         -- Return the original expression, not the type-decorated one
 119     readMutVar pending_splices          `thenM` \ pendings ->
 120     returnM (noLoc (HsBracketOut brack pendings))
 121     }
 122
 123 tc_bracket :: HsBracket Name -> TcM TcType
 124 tc_bracket (VarBr v)
 125   = tcMetaTy nameTyConName
 126         -- Result type is Var (not Q-monadic)
 127
 128 tc_bracket (ExpBr expr)
 129   = newTyVarTy liftedTypeKind   `thenM` \ any_ty ->
 130     tcCheckRho expr any_ty      `thenM_`
 131     tcMetaTy expQTyConName
 132         -- Result type is Expr (= Q Exp)
 133
 134 tc_bracket (TypBr typ)
 135   = tcHsSigType ExprSigCtxt typ         `thenM_`
 136     tcMetaTy typeQTyConName
 137         -- Result type is Type (= Q Typ)
 138
 139 tc_bracket (DecBr decls)
 140   = tcTopSrcDecls decls         `thenM_`
 141         -- Typecheck the declarations, dicarding the result
 142         -- We'll get all that stuff later, when we splice it in
 143
 144     tcMetaTy decTyConName       `thenM` \ decl_ty ->
 145     tcMetaTy qTyConName         `thenM` \ q_ty ->
 146     returnM (mkAppTy q_ty (mkListTy decl_ty))
 147         -- Result type is Q [Dec]
 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   = addSrcSpan (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     zapExpectedType res_ty liftedTypeKind       `thenM_`
 177     tcMetaTy expQTyConName                      `thenM` \ meta_exp_ty ->
 178     setStage (Splice next_level) (
 179         setLIEVar lie_var          $
 180         tcCheckRho 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 -> Expected TcType -> 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 zonked_q_expr              `thenM` \ simple_expr ->
 207
 208     let
 209         -- simple_expr :: TH.Exp
 210
 211         expr2 :: LHsExpr RdrName
 212         expr2 = convertToHsExpr simple_expr
 213     in
 214     traceTc (text "Got result" <+> ppr expr2)   `thenM_`
 215
 216     showSplice "expression"
 217                zonked_q_expr (ppr expr2)        `thenM_`
 218
 219         -- Rename it, but bale out if there are errors
 220         -- otherwise the type checker just gives more spurious errors
 221     checkNoErrs (rnLExpr expr2)                 `thenM` \ (exp3, fvs) ->
 222
 223     tcMonoExpr exp3 res_ty
 224
 225
 226 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
 227 -- Type check an expression that is the body of a top-level splice
 228 --   (the caller will compile and run it)
 229 tcTopSpliceExpr expr meta_ty
 230   = checkNoErrs $       -- checkNoErrs: must not try to run the thing
 231                         --              if the type checker fails!
 232
 233     setStage topSpliceStage $ do
 234
 235
 236     do  { recordThUse   -- Record that TH is used (for pkg depdendency)
 237
 238         -- Typecheck the expression
 239         ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty)
 240
 241         -- Solve the constraints
 242         ; const_binds <- tcSimplifyTop lie
 243
 244         -- And zonk it
 245         ; zonkTopLExpr (mkHsLet const_binds expr') }
 246 \end{code}
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251                 Splicing a type
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 Very like splicing an expression, but we don't yet share code.
 256
 257 \begin{code}
 258 kcSpliceType (HsSplice name hs_expr)
 259   = addSrcSpan (getLoc hs_expr) $ do
 260         { level <- getStage
 261         ; case spliceOK level of {
 262                 Nothing         -> failWithTc (illegalSplice level) ;
 263                 Just next_level -> do
 264
 265         { case level of {
 266                 Comp                   -> do { (t,k) <- kcTopSpliceType hs_expr
 267                                              ; return (unLoc t, k) } ;
 268                 Brack _ ps_var lie_var -> do
 269
 270         {       -- A splice inside brackets
 271         ; meta_ty <- tcMetaTy typeQTyConName
 272         ; expr' <- setStage (Splice next_level) $
 273                    setLIEVar lie_var            $
 274                    tcCheckRho hs_expr meta_ty
 275
 276                 -- Write the pending splice into the bucket
 277         ; ps <- readMutVar ps_var
 278         ; writeMutVar ps_var ((name,expr') : ps)
 279
 280         -- e.g.   [| Int -> $(h 4) |]
 281         -- Here (h 4) :: Q Type
 282         -- but $(h 4) :: forall a.a     i.e. any kind
 283         ; kind <- newKindVar
 284         ; returnM (panic "kcSpliceType", kind)  -- The returned type is ignored
 285     }}}}}
 286
 287 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
 288 kcTopSpliceType expr
 289   = do  { meta_ty <- tcMetaTy typeQTyConName
 290
 291         -- Typecheck the expression
 292         ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
 293
 294         -- Run the expression
 295         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 296         ; simple_ty <- runMetaT zonked_q_expr
 297
 298         ; let   -- simple_ty :: TH.Type
 299                 hs_ty2 :: LHsType RdrName
 300                 hs_ty2 = convertToHsType simple_ty
 301
 302         ; traceTc (text "Got result" <+> ppr hs_ty2)
 303
 304         ; showSplice "type" zonked_q_expr (ppr hs_ty2)
 305
 306         -- Rename it, but bale out if there are errors
 307         -- otherwise the type checker just gives more spurious errors
 308         ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
 309         ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
 310
 311         ; kcHsType hs_ty3 }
 312 \end{code}
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection{Splicing an expression}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 \begin{code}
 321 -- Always at top level
 322 tcSpliceDecls expr
 323   = do  { meta_dec_ty <- tcMetaTy decTyConName
 324         ; meta_q_ty <- tcMetaTy qTyConName
 325         ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
 326         ; zonked_q_expr <- tcTopSpliceExpr expr list_q
 327
 328                 -- Run the expression
 329         ; traceTc (text "About to run" <+> ppr zonked_q_expr)
 330         ; simple_expr <- runMetaD zonked_q_expr
 331
 332             -- simple_expr :: [TH.Dec]
 333             -- decls :: [RdrNameHsDecl]
 334         ; decls <- handleErrors (convertToHsDecls simple_expr)
 335         ; traceTc (text "Got result" <+> vcat (map ppr decls))
 336         ; showSplice "declarations"
 337                      zonked_q_expr (vcat (map ppr decls))
 338         ; returnM decls }
 339
 340   where handleErrors :: [Either a Message] -> TcM [a]
 341         handleErrors [] = return []
 342         handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
 343         handleErrors (Right m:xs) = do addErrTc m
 344                                        handleErrors xs
 345 \end{code}
 346
 347
 348 %************************************************************************
 349 %*                                                                      *
 350 \subsection{Running an expression}
 351 %*                                                                      *
 352 %************************************************************************
 353
 354 \begin{code}
 355 runMetaE :: LHsExpr Id  -- Of type (Q Exp)
 356          -> TcM TH.Exp  -- Of type Exp
 357 runMetaE e = runMeta e
 358
 359 runMetaT :: LHsExpr Id          -- Of type (Q Type)
 360          -> TcM TH.Type         -- Of type Type
 361 runMetaT e = runMeta e
 362
 363 runMetaD :: LHsExpr Id          -- Of type Q [Dec]
 364          -> TcM [TH.Dec]        -- Of type [Dec]
 365 runMetaD e = runMeta e
 366
 367 runMeta :: LHsExpr Id           -- Of type X
 368         -> TcM t                -- Of type t
 369 runMeta expr
 370   = do  { hsc_env <- getTopEnv
 371         ; tcg_env <- getGblEnv
 372         ; this_mod <- getModule
 373         ; let type_env = tcg_type_env tcg_env
 374               rdr_env  = tcg_rdr_env tcg_env
 375         -- Wrap the compile-and-run in an exception-catcher
 376         -- Compiling might fail if linking fails
 377         -- Running might fail if it throws an exception
 378         ; either_tval <- tryM $ do
 379                 {       -- Compile it
 380                   hval <- ioToTcRn (HscMain.compileExpr
 381                                       hsc_env this_mod
 382                                       rdr_env type_env expr)
 383                         -- Coerce it to Q t, and run it
 384                 ; TH.runQ (unsafeCoerce# hval) }
 385
 386         ; case either_tval of
 387               Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:",
 388                                             nest 4 (vcat [text "Code:" <+> ppr expr,
 389                                                       text ("Exn: " ++ Panic.showException exn)])])
 390               Right v  -> returnM v }
 391 \end{code}
 392
 393 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
 394
 395 \begin{code}
 396 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
 397   qNewName s = do  { u <- newUnique
 398                   ; let i = getKey u
 399                   ; return (TH.mkNameU s i) }
 400
 401   qReport True msg  = addErr (text msg)
 402   qReport False msg = addReport (text msg)
 403
 404   qCurrentModule = do { m <- getModule; return (moduleUserString m) }
 405   qReify v = reify v
 406   qRecover = recoverM
 407
 408   qRunIO io = ioToTcRn io
 409 \end{code}
 410
 411
 412 %************************************************************************
 413 %*                                                                      *
 414 \subsection{Errors and contexts}
 415 %*                                                                      *
 416 %************************************************************************
 417
 418 \begin{code}
 419 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
 420 showSplice what before after
 421   = getSrcSpanM         `thenM` \ loc ->
 422     traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
 423                        nest 2 (sep [nest 2 (ppr before),
 424                                     text "======>",
 425                                     nest 2 after])])
 426
 427 illegalBracket level
 428   = ptext SLIT("Illegal bracket at level") <+> ppr level
 429
 430 illegalSplice level
 431   = ptext SLIT("Illegal splice at level") <+> ppr level
 432
 433 #endif  /* GHCI */
 434 \end{code}
 435
 436
 437 %************************************************************************
 438 %*                                                                      *
 439                         Reification
 440 %*                                                                      *
 441 %************************************************************************
 442
 443
 444 \begin{code}
 445 reify :: TH.Name -> TcM TH.Info
 446 reify th_name
 447   = do  { name <- lookupThName th_name
 448         ; thing <- tcLookupTh name
 449                 -- ToDo: this tcLookup could fail, which would give a
 450                 --       rather unhelpful error message
 451         ; reifyThing thing
 452     }
 453
 454 lookupThName :: TH.Name -> TcM Name
 455 lookupThName (TH.Name occ (TH.NameG th_ns mod))
 456   = lookupOrig (mkModuleName (TH.modString mod))
 457                (OccName.mkOccName ghc_ns (TH.occString occ))
 458   where
 459     ghc_ns = case th_ns of
 460                 TH.DataName  -> dataName
 461                 TH.TcClsName -> tcClsName
 462                 TH.VarName   -> varName
 463
 464 lookupThName th_name@(TH.Name occ TH.NameS)
 465   =  do { let rdr_name = mkRdrUnqual (OccName.mkOccFS ns occ_fs)
 466         ; rdr_env <- getLocalRdrEnv
 467         ; case lookupLocalRdrEnv rdr_env rdr_name of
 468                 Just name -> return name
 469                 Nothing   -> do
 470         { mb_name <- lookupSrcOcc_maybe rdr_name
 471         ; case mb_name of
 472             Just name -> return name ;
 473             Nothing   -> failWithTc (notInScope th_name)
 474         }}
 475   where
 476     ns | isLexCon occ_fs = OccName.dataName
 477        | otherwise       = OccName.varName
 478     occ_fs = mkFastString (TH.occString occ)
 479
 480 lookupThName (TH.Name occ (TH.NameU uniq))
 481   = return (mkInternalName (mk_uniq uniq) (OccName.mkOccFS bogus_ns occ_fs) noSrcLoc)
 482   where
 483     occ_fs = mkFastString (TH.occString occ)
 484     bogus_ns = OccName.varName  -- Not yet recorded in the TH name
 485                                 -- but only the unique matters
 486
 487 tcLookupTh :: Name -> TcM TcTyThing
 488 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
 489 -- it gives a reify-related error message on failure, whereas in the normal
 490 -- tcLookup, failure is a bug.
 491 tcLookupTh name
 492   = do  { (gbl_env, lcl_env) <- getEnvs
 493         ; case lookupNameEnv (tcl_env lcl_env) name of
 494                 Just thing -> returnM thing
 495                 Nothing    -> do
 496         { if nameIsLocalOrFrom (tcg_mod gbl_env) name
 497           then  -- It's defined in this module
 498               case lookupNameEnv (tcg_type_env gbl_env) name of
 499                 Just thing -> return (AGlobal thing)
 500                 Nothing    -> failWithTc (notInEnv name)
 501
 502           else do               -- It's imported
 503         { (eps,hpt) <- getEpsAndHpt
 504         ; case lookupType hpt (eps_PTE eps) name of
 505             Just thing -> return (AGlobal thing)
 506             Nothing    -> do { traceIf (text "tcLookupGlobal" <+> ppr name)
 507                              ; thing <- initIfaceTcRn (tcImportDecl name)
 508                              ; return (AGlobal thing) }
 509                 -- Imported names should always be findable;
 510                 -- if not, we fail hard in tcImportDecl
 511     }}}
 512
 513 mk_uniq :: Int# -> Unique
 514 mk_uniq u = mkUniqueGrimily (I# u)
 515
 516 notInScope :: TH.Name -> SDoc
 517 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
 518                      ptext SLIT("is not in scope at a reify")
 519         -- Ugh! Rather an indirect way to display the name
 520
 521 notInEnv :: Name -> SDoc
 522 notInEnv name = quotes (ppr name) <+>
 523                      ptext SLIT("is not in the type environment at a reify")
 524
 525 ------------------------------
 526 reifyThing :: TcTyThing -> TcM TH.Info
 527 -- The only reason this is monadic is for error reporting,
 528 -- which in turn is mainly for the case when TH can't express
 529 -- some random GHC extension
 530
 531 reifyThing (AGlobal (AnId id))
 532   = do  { ty <- reifyType (idType id)
 533         ; fix <- reifyFixity (idName id)
 534         ; let v = reifyName id
 535         ; case globalIdDetails id of
 536             ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
 537             other            -> return (TH.VarI     v ty Nothing fix)
 538     }
 539
 540 reifyThing (AGlobal (ATyCon tc))   = do { dec <- reifyTyCon tc;  return (TH.TyConI dec) }
 541 reifyThing (AGlobal (AClass cls))  = do { dec <- reifyClass cls; return (TH.ClassI dec) }
 542 reifyThing (AGlobal (ADataCon dc))
 543   = do  { let name = dataConName dc
 544         ; ty <- reifyType (idType (dataConWrapId dc))
 545         ; fix <- reifyFixity name
 546         ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
 547
 548 reifyThing (ATcId id _ _)
 549   = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
 550                                         -- though it may be incomplete
 551         ; ty2 <- reifyType ty1
 552         ; fix <- reifyFixity (idName id)
 553         ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
 554
 555 reifyThing (ATyVar tv)
 556   = do  { ty1 <- zonkTcTyVar tv
 557         ; ty2 <- reifyType ty1
 558         ; return (TH.TyVarI (reifyName tv) ty2) }
 559
 560 ------------------------------
 561 reifyTyCon :: TyCon -> TcM TH.Dec
 562 reifyTyCon tc
 563   | isSynTyCon tc
 564   = do  { let (tvs, rhs) = getSynTyConDefn tc
 565         ; rhs' <- reifyType rhs
 566         ; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 567
 568   | isNewTyCon tc
 569   = do  { cxt <- reifyCxt (tyConTheta tc)
 570         ; con <- reifyDataCon (head (tyConDataCons tc))
 571         ; return (TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
 572                               con [{- Don't know about deriving -}]) }
 573
 574   | otherwise   -- Algebraic
 575   = do  { cxt <- reifyCxt (tyConTheta tc)
 576         ; cons <- mapM reifyDataCon (tyConDataCons tc)
 577         ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
 578                               cons [{- Don't know about deriving -}]) }
 579
 580 reifyDataCon :: DataCon -> TcM TH.Con
 581 reifyDataCon dc
 582   = do  { arg_tys <- reifyTypes (dataConOrigArgTys dc)
 583         ; let stricts = map reifyStrict (dataConStrictMarks dc)
 584               fields  = dataConFieldLabels dc
 585               name    = reifyName dc
 586               [a1,a2] = arg_tys
 587               [s1,s2] = stricts
 588         ; ASSERT( length arg_tys == length stricts )
 589           if not (null fields) then
 590              return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
 591           else
 592           if dataConIsInfix dc then
 593              ASSERT( length arg_tys == 2 )
 594              return (TH.InfixC (s1,a1) name (s1,a2))
 595           else
 596              return (TH.NormalC name (stricts `zip` arg_tys)) }
 597
 598 ------------------------------
 599 reifyClass :: Class -> TcM TH.Dec
 600 reifyClass cls
 601   = do  { cxt <- reifyCxt theta
 602         ; ops <- mapM reify_op op_stuff
 603         ; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) ops) }
 604   where
 605     (tvs, theta, _, op_stuff) = classBigSig cls
 606     reify_op (op, _) = do { ty <- reifyType (idType op)
 607                           ; return (TH.SigD (reifyName op) ty) }
 608
 609 ------------------------------
 610 reifyType :: TypeRep.Type -> TcM TH.Type
 611 reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
 612 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
 613 reifyType (NewTcApp tc tys) = reify_tc_app (reifyName tc) tys
 614 reifyType (NoteTy _ ty)     = reifyType ty
 615 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
 616 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
 617 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
 618                                  ; tau' <- reifyType tau
 619                                  ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
 620                             where
 621                                 (tvs, cxt, tau) = tcSplitSigmaTy ty
 622 reifyTypes = mapM reifyType
 623 reifyCxt   = mapM reifyPred
 624
 625 reifyTyVars :: [TyVar] -> [TH.Name]
 626 reifyTyVars = map reifyName
 627
 628 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 629 reify_tc_app tc tys = do { tys' <- reifyTypes tys
 630                          ; return (foldl TH.AppT (TH.ConT tc) tys') }
 631
 632 reifyPred :: TypeRep.PredType -> TcM TH.Type
 633 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
 634 reifyPred p@(IParam _ _)   = noTH SLIT("implicit parameters") (ppr p)
 635
 636
 637 ------------------------------
 638 reifyName :: NamedThing n => n -> TH.Name
 639 reifyName thing
 640   | isExternalName name = mk_varg mod occ_str
 641   | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
 642   where
 643     name    = getName thing
 644     mod     = moduleUserString (nameModule name)
 645     occ_str = occNameUserString occ
 646     occ     = nameOccName name
 647     mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
 648             | OccName.isVarOcc  occ = TH.mkNameG_v
 649             | OccName.isTcOcc   occ = TH.mkNameG_tc
 650             | otherwise             = pprPanic "reifyName" (ppr name)
 651
 652 ------------------------------
 653 reifyFixity :: Name -> TcM TH.Fixity
 654 reifyFixity name
 655   = do  { fix <- lookupFixityRn name
 656         ; return (conv_fix fix) }
 657     where
 658       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
 659       conv_dir BasicTypes.InfixR = TH.InfixR
 660       conv_dir BasicTypes.InfixL = TH.InfixL
 661       conv_dir BasicTypes.InfixN = TH.InfixN
 662
 663 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
 664 reifyStrict MarkedStrict    = TH.IsStrict
 665 reifyStrict MarkedUnboxed   = TH.IsStrict
 666 reifyStrict NotMarkedStrict = TH.NotStrict
 667
 668 ------------------------------
 669 noTH :: LitString -> SDoc -> TcM a
 670 noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
 671                                 ptext SLIT("in Template Haskell:"),
 672                              nest 2 d])
 673 \end{code}