From 5f7e4514c5d913aabdcacf42161b745876bbc21d Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 21 Nov 2002 09:37:25 +0000
Subject: [PATCH] [project @ 2002-11-21 09:37:24 by simonpj] More wibbles to
 improve declaration splicing

---
 ghc/compiler/deSugar/DsMeta.hs        |   32 +++++++++++++++++++-------------
 ghc/compiler/hsSyn/Convert.lhs        |    2 +-
 ghc/compiler/typecheck/TcRnDriver.lhs |    4 ++--
 ghc/compiler/typecheck/TcSplice.lhs   |    4 +---
 4 files changed, 23 insertions(+), 19 deletions(-)

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index b5cd548..66e09bb 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -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] }
diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 7601848..0a0d64b 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -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(..),
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 8a3ca32..24438fa 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -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
diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 5665abc..088c498 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -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
-- 
1.7.10.4