Commit 5f7e4514 authored by simonpj's avatar simonpj

[project @ 2002-11-21 09:37:24 by simonpj]

More wibbles to improve declaration splicing
parent b8598510
......@@ -66,6 +66,7 @@ import TysWiredIn ( stringTy )
import CoreSyn
import CoreUtils ( exprType )
import SrcLoc ( noSrcLoc )
import Maybes ( orElse )
import Maybe ( catMaybes, fromMaybe )
import Panic ( panic )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
......@@ -143,7 +144,7 @@ repTopDs group
-- do { t :: String <- genSym "T" ;
-- return (Data t [] ...more t's... }
-- The other important reason is that the output must mention
-- only "T", not "Foo.T" where Foo is the current module
-- only "T", not "Foo:T" where Foo is the current module
decls <- addBinds ss (do {
......@@ -214,17 +215,22 @@ repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty })
return (Just dec) }
repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
tcdTyVars = tvs, tcdFDs = [],
tcdSigs = sigs, tcdMeths = Just binds }) =
do
cls1 <- lookupOcc cls -- See note [Binders and occurrences]
dec <- addTyVarBinds tvs $ \bndrs -> do
cxt1 <- repContext cxt
sigs1 <- rep_sigs sigs
binds1 <- rep_monobind binds
decls1 <- coreList declTyConName (sigs1 ++ binds1)
repClass cxt1 cls1 (coreList' stringTy bndrs) decls1
return $ Just dec
tcdTyVars = tvs,
tcdFDs = [], -- We don't understand functional dependencies
tcdSigs = sigs, tcdMeths = mb_meth_binds })
= do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
dec <- addTyVarBinds tvs $ \bndrs -> do {
cxt1 <- repContext cxt ;
sigs1 <- rep_sigs sigs ;
binds1 <- rep_monobind meth_binds ;
decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
return $ Just dec }
where
-- If the user quotes a class decl, it'll have default-method
-- bindings; but if we (reifyDecl C) where C is a class, we
-- won't be given the default methods (a definite infelicity).
meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
-- Un-handled cases
repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
......@@ -293,7 +299,7 @@ rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
rep_sig (Sig nm ty _) = rep_proto nm ty
rep_sig other = return []
rep_proto nm ty = do { nm1 <- lookupBinder nm ;
rep_proto nm ty = do { nm1 <- lookupOcc nm ;
ty1 <- repTy ty ;
sig <- repProto nm1 ty1 ;
return [sig] }
......
......@@ -14,7 +14,7 @@ import Language.Haskell.THSyntax as Meta
import HsSyn as Hs
( HsExpr(..), HsLit(..), ArithSeqInfo(..),
HsStmtContext(..),
HsStmtContext(..), TyClDecl(..),
Match(..), GRHSs(..), GRHS(..), HsPred(..),
HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
......
......@@ -17,7 +17,7 @@ module TcRnDriver (
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
import DsMeta ( qTyConName )
import DsMeta ( templateHaskellNames )
#endif
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
......@@ -616,7 +616,7 @@ tcRnSrcDecls ds
(rn_splice_expr, fvs) <- initRn SourceMode $
addSrcLoc splice_loc $
rnExpr splice_expr ;
tcg_env <- importSupportingDecls (fvs `addOneFV` qTyConName) ;
tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ;
setGblEnv tcg_env $ do {
-- Execute the splice
......
......@@ -209,10 +209,8 @@ runMetaD :: TypecheckedHsExpr -- Of type Q [Dec]
-> TcM [Meta.Dec] -- Of type [Dec]
runMetaD e = runMeta e
-- Warning: if Q is anything other than IO, we need to change this
tcRunQ :: Meta.Q a -> TcM a
tcRunQ (Meta.Q thing) = ioToTcRn thing
tcRunQ thing = ioToTcRn (Meta.runQ thing)
runMeta :: TypecheckedHsExpr -- Of type X
-> TcM t -- Of type t
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment