[project @ 2004-03-11 10:52:55 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcClassDcl.lhs

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 251dc8a..ee506bc 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -45,8 +45,7 @@ import Subst          ( substTyWith )
 import MkId            ( mkDefaultMethodId, mkDictFunId )
 import Id              ( Id, idType, idName, mkUserLocal, setInlinePragma )
 import Name            ( Name, NamedThing(..) )
-import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
-                         plusNameEnv, mkNameEnv )
+import NameEnv         ( NameEnv, lookupNameEnv, mkNameEnv )
 import NameSet         ( emptyNameSet, unitNameSet, nameSetToList )
 import OccName         ( reportIfUnused, mkDefaultMethodOcc )
 import RdrName         ( RdrName, mkDerivedRdrName )
@@ -59,7 +58,7 @@ import ErrUtils               ( dumpIfSet_dyn )
 import Util            ( count, lengthIs, isSingleton, lengthExceeds )
 import Unique          ( Uniquable(..) )
 import ListSetOps      ( equivClassesByUniq, minusList )
-import SrcLoc          ( SrcLoc, Located(..), srcSpanStart, unLoc, noLoc )
+import SrcLoc          ( Located(..), srcSpanStart, unLoc, noLoc )
 import Maybes          ( seqMaybe, isJust, mapCatMaybes )
 import List            ( partition )
 import Bag
@@ -337,7 +336,13 @@ tcMethodBind
 
 tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
             (sel_id, meth_id, meth_bind)
-  =    -- Check the bindings; first adding inst_tyvars to the envt
+  = recoverM (returnM emptyBag) $
+       -- If anything fails, recover returning no bindings.
+       -- This is particularly useful when checking the default-method binding of
+       -- a class decl. If we don't recover, we don't add the default method to
+       -- the type enviroment, and we get a tcLookup failure on $dmeth later.
+
+       -- Check the bindings; first adding inst_tyvars to the envt
        -- so that we don't quantify over them in nested places
      mkTcSig meth_id                           `thenM` \ meth_sig ->
 
@@ -611,7 +616,7 @@ gives rise to the instance declarations
 \begin{code}
 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo] 
 getGenericInstances class_decls
-  = do { gen_inst_infos <- mappM get_generics class_decls
+  = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls
        ; let { gen_inst_info = concat gen_inst_infos }
 
        -- Return right away if there is no generic stuff
@@ -624,7 +629,7 @@ getGenericInstances class_decls
                   (vcat (map pprInstInfoDetails gen_inst_info)))       
        ; returnM gen_inst_info }}
 
-get_generics decl@(L loc (ClassDecl {tcdLName = class_name, tcdMeths = def_methods}))
+get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
   | null generic_binds
   = returnM [] -- The comon case: no generic default methods
 
@@ -638,8 +643,7 @@ get_generics decl@(L loc (ClassDecl {tcdLName = class_name, tcdMeths = def_metho
     let
        groups = groupWith listToBag generic_binds
     in
-    mappM (mkGenericInstance clas (srcSpanStart loc)) groups
-                                               `thenM` \ inst_infos ->
+    mappM (mkGenericInstance clas) groups              `thenM` \ inst_infos ->
 
        -- Check that there is only one InstInfo for each type constructor
        -- The main way this can fail is if you write
@@ -704,11 +708,11 @@ eqPatType t1                   (HsParTy t2)       = t1 `eqPatType` unLoc t2
 eqPatType _ _ = False
 
 ---------------------------------
-mkGenericInstance :: Class -> SrcLoc
+mkGenericInstance :: Class
                  -> (HsType Name, LHsBinds Name)
                  -> TcM InstInfo
 
-mkGenericInstance clas loc (hs_ty, binds)
+mkGenericInstance clas (hs_ty, binds)
   -- Make a generic instance declaration
   -- For example:      instance (C a, C b) => C (a+b) where { binds }
 
@@ -728,7 +732,8 @@ mkGenericInstance clas loc (hs_ty, binds)
            (badGenericInstanceType binds)      `thenM_`
 
        -- Make the dictionary function.
-    newDFunName clas [inst_ty] loc             `thenM` \ dfun_name ->
+    getSrcSpanM                                                `thenM` \ span -> 
+    newDFunName clas [inst_ty] (srcSpanStart span)     `thenM` \ dfun_name ->
     let
        inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
        dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
@@ -745,10 +750,8 @@ mkGenericInstance clas loc (hs_ty, binds)
 %************************************************************************
 
 \begin{code}
-tcAddDeclCtxt (L loc decl) thing_inside
-  = addSrcSpan loc     $
-    addErrCtxt ctxt    $
-    thing_inside
+tcAddDeclCtxt decl thing_inside
+  = addErrCtxt ctxt thing_inside
   where
      thing = case decl of
                ClassDecl {}              -> "class"