[project @ 2002-11-21 17:54:54 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index f74202e..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 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] }
@@ -303,16 +309,9 @@ rep_proto nm ty = do { nm1 <- lookupBinder nm ;
 --                     Types
 -------------------------------------------------------
 
--- represent a list of type variables in a usage position that does not need
--- gensym'ing
---
-repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
-repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
-                 return (coreList' stringTy tvs1) } 
-
 -- gensym a list of type variables and enter them into the meta environment;
 -- the computations passed as the second argument is executed in that extended
--- meta environment and gets the *original* names as an argument
+-- meta environment and gets the *new* names on Core-level as an argument
 --
 addTyVarBinds :: [HsTyVarBndr Name]             -- the binders to be added
              -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env