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

More wibbles to improve declaration splicing

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index b5cd548..66e09bb 100644 (file)
--- 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 CoreSyn
 import CoreUtils  ( exprType )
 import SrcLoc    ( noSrcLoc )

+import Maybes    ( orElse )

 import Maybe     ( catMaybes, fromMaybe )
 import Panic     ( panic )
 import Unique    ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
 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
        --      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 {
 
        
        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, 
        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)) ;
 
 -- 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_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] }
                       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 (file)
--- 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(..), 
 
 import HsSyn as Hs
        (       HsExpr(..), HsLit(..), ArithSeqInfo(..), 

-               HsStmtContext(..), 
+               HsStmtContext(..), TyClDecl(..),

                Match(..), GRHSs(..), GRHS(..), HsPred(..),
                HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
                Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
                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 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -17,7 +17,7 @@ module TcRnDriver (
 
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
 
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )

-import               DsMeta   ( qTyConName )
+import               DsMeta   ( templateHaskellNames )

 #endif
 
 import CmdLineOpts     ( DynFlag(..), opt_PprStyle_Debug, dopt )
 #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 ;
        (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
        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 (file)
--- 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
 
         -> 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 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
 
 runMeta :: TypecheckedHsExpr   -- Of type X
        -> TcM t                -- Of type t