[project @ 2002-02-28 12:17:19 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcClassDcl.lhs
index 70f99fd..3f32e87 100644 (file)
@@ -4,14 +4,14 @@
 \section[TcClassDcl]{Typechecking class declarations}
 
 \begin{code}
-module TcClassDcl ( tcClassDecl1, tcClassDecls2, 
+module TcClassDcl ( tcClassDecl1, checkValidClass, tcClassDecls2, 
                    tcMethodBind, badMethodErr
                  ) where
 
 #include "HsVersions.h"
 
 import HsSyn           ( TyClDecl(..), Sig(..), MonoBinds(..),
-                         HsExpr(..), HsLit(..), HsType(..), HsPred(..), 
+                         HsExpr(..), HsLit(..), 
                          mkSimpleMatch, andMonoBinds, andMonoBindList, 
                          isClassOpSig, isPragSig,
                          getClassDeclSysNames, placeHolderType
@@ -19,40 +19,42 @@ import HsSyn                ( TyClDecl(..), Sig(..), MonoBinds(..),
 import BasicTypes      ( TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
 import RnHsSyn         ( RenamedTyClDecl, 
                          RenamedClassOpSig, RenamedMonoBinds,
-                         RenamedContext, RenamedSig, 
-                         maybeGenericMatch
+                         RenamedSig, maybeGenericMatch
                        )
 import TcHsSyn         ( TcMonoBinds )
 
 import Inst            ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, 
                          instToId, newDicts, newMethod )
-import TcEnv           ( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
-                         tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
+import TcEnv           ( TyThingDetails(..), tcExtendGlobalTyVars,
+                         tcLookupClass, tcExtendTyVarEnvForMeths, 
                          tcExtendLocalValEnv, tcExtendTyVarEnv
                        )
 import TcBinds         ( tcBindWithSigs, tcSpecSigs )
-import TcMonoType      ( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
+import TcMonoType      ( tcHsType, tcHsTheta, mkTcSig )
 import TcSimplify      ( tcSimplifyCheck, bindInstsOfLocalFuns )
-import TcMType         ( tcInstTyVars )
-import TcType          ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred, tcIsTyVarTy, tcSplitTyConApp_maybe )
+import TcUnify         ( checkSigTyVars, sigCtxt )
+import TcMType         ( tcInstSigTyVars, checkValidTheta, checkValidType, SourceTyCtxt(..), UserTypeCtxt(..) )
+import TcType          ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, 
+                         mkTyVarTys, mkPredTys, mkClassPred, 
+                         tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitSigmaTy
+                       )
 import TcMonad
 import Generics                ( mkGenericRhs, validGenericMethodType )
 import PrelInfo                ( nO_METHOD_BINDING_ERROR_ID )
-import Class           ( classTyVars, classBigSig, classTyCon, 
+import Class           ( classTyVars, classBigSig, classTyCon, className,
                          Class, ClassOpItem, DefMeth (..) )
 import MkId            ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon         ( mkDataCon )
-import Id              ( Id, idType, idName )
+import Id              ( Id, idType, idName, setIdLocalExported )
 import Module          ( Module )
 import Name            ( Name, NamedThing(..) )
-import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
+import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
 import NameSet         ( emptyNameSet )
 import Outputable
 import Var             ( TyVar )
-import VarSet          ( mkVarSet, emptyVarSet )
 import CmdLineOpts
 import ErrUtils                ( dumpIfSet )
-import Util            ( count )
+import Util            ( count, isSingleton, lengthIs, equalLength )
 import Maybes          ( seqMaybe, maybeToBool )
 \end{code}
 
@@ -99,21 +101,12 @@ Death to "ExpandingDicts".
 
 \begin{code}
 
-tcClassDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcClassDecl1 is_rec rec_env
-            (ClassDecl {tcdCtxt = context, tcdName = class_name,
+tcClassDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name,
                         tcdTyVars = tyvar_names, tcdFDs = fundeps,
                         tcdSigs = class_sigs, tcdMeths = def_methods,
                         tcdSysNames = sys_names, tcdLoc = src_loc})
-  =    -- CHECK ARITY 1 FOR HASKELL 1.4
-    doptsTc Opt_GlasgowExts                            `thenTc` \ gla_ext_opt ->
-    let
-       gla_exts = gla_ext_opt || not (maybeToBool def_methods)
-               -- Accept extensions if gla_exts is on,
-               -- or if we're looking at an interface file decl
-    in         -- (in which case def_methods = Nothing
-
-       -- LOOK THINGS UP IN THE ENVIRONMENT
+  =    -- LOOK THINGS UP IN THE ENVIRONMENT
     tcLookupClass class_name                           `thenTc` \ clas ->
     let
        tyvars   = classTyVars clas
@@ -123,31 +116,24 @@ tcClassDecl1 is_rec rec_env
     in
     tcExtendTyVarEnv tyvars                            $ 
 
-       -- SOURCE-CODE CONSISTENCY CHECKS
-    (case def_methods of
-       Nothing  ->     -- Not source
-                   returnTc Nothing    
-
-       Just dms ->     -- Source so do error checks
-                   checkTc (gla_exts || length tyvar_names == 1)
-                           (classArityErr class_name)                  `thenTc_`
-
-                   checkDefaultBinds clas op_names dms   `thenTc` \ dm_env ->
-                   checkGenericClassIsUnary clas dm_env  `thenTc_`
-                   returnTc (Just dm_env)
-    )                                                     `thenTc` \ mb_dm_env ->
+    checkDefaultBinds clas op_names def_methods          `thenTc` \ mb_dm_env ->
        
        -- CHECK THE CONTEXT
-    tcSuperClasses is_rec gla_exts clas context sc_sel_names   `thenTc` \ (sc_theta, sc_sel_ids) ->
+       -- The renamer has already checked that the context mentions
+       -- only the type variable of the class decl.
+       -- Context is already kind-checked
+    ASSERT( equalLength context sc_sel_names )
+    tcHsTheta context                                  `thenTc` \ sc_theta ->
 
        -- CHECK THE CLASS SIGNATURES,
-    mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs    `thenTc` \ sig_stuff ->
+    mapTc (tcClassSig clas tyvars mb_dm_env) op_sigs   `thenTc` \ sig_stuff ->
 
        -- MAKE THE CLASS DETAILS
     let
        (op_tys, op_items) = unzip sig_stuff
         sc_tys            = mkPredTys sc_theta
        dict_component_tys = sc_tys ++ op_tys
+        sc_sel_ids        = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
 
         dict_con = mkDataCon datacon_name
                             [NotMarkedStrict | _ <- dict_component_tys]
@@ -166,8 +152,8 @@ tcClassDecl1 is_rec rec_env
 \end{code}
 
 \begin{code}
-checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds
-                 -> TcM (NameEnv Bool)
+checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds
+                 -> TcM (Maybe (NameEnv Bool))
        -- The returned environment says
        --      x not in env => no default method
        --      x -> True    => generic default method
@@ -180,77 +166,42 @@ checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds
 
   -- But do all this only for source binds
 
-checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv
+checkDefaultBinds clas ops Nothing
+  = returnTc Nothing
+
+checkDefaultBinds clas ops (Just mbs)
+  = go mbs     `thenTc` \ dm_env ->
+    returnTc (Just dm_env)
+  where
+    go EmptyMonoBinds = returnTc emptyNameEnv
 
-checkDefaultBinds clas ops (AndMonoBinds b1 b2)
-  = checkDefaultBinds clas ops b1      `thenTc` \ dm_info1 ->
-    checkDefaultBinds clas ops b2      `thenTc` \ dm_info2 ->
-    returnTc (dm_info1 `plusNameEnv` dm_info2)
+    go (AndMonoBinds b1 b2)
+      = go b1  `thenTc` \ dm_info1 ->
+        go b2  `thenTc` \ dm_info2 ->
+        returnTc (dm_info1 `plusNameEnv` dm_info2)
 
-checkDefaultBinds clas ops (FunMonoBind op _ matches loc)
-  = tcAddSrcLoc loc                                    $
+    go (FunMonoBind op _ matches loc)
+      = tcAddSrcLoc loc                                        $
 
        -- Check that the op is from this class
-    checkTc (op `elem` ops) (badMethodErr clas op)             `thenTc_`
+       checkTc (op `elem` ops) (badMethodErr clas op)          `thenTc_`
 
        -- Check that all the defns ar generic, or none are
-    checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
+       checkTc (all_generic || none_generic) (mixedGenericErr op)      `thenTc_`
 
-    returnTc (unitNameEnv op all_generic)
-  where
-    n_generic    = count (maybeToBool . maybeGenericMatch) matches
-    none_generic = n_generic == 0
-    all_generic  = n_generic == length matches
-
-checkGenericClassIsUnary clas dm_env
-  = -- Check that if the class has generic methods, then the
-    -- class has only one parameter.  We can't do generic
-    -- multi-parameter type classes!
-    checkTc (unary || no_generics) (genericMultiParamErr clas)
-  where
-    unary      = length (classTyVars clas) == 1
-    no_generics = not (or (nameEnvElts dm_env))
+       returnTc (unitNameEnv op all_generic)
+      where
+       n_generic    = count (maybeToBool . maybeGenericMatch) matches
+       none_generic = n_generic == 0
+       all_generic  = matches `lengthIs` n_generic
 \end{code}
 
 
 \begin{code}
-tcSuperClasses :: RecFlag -> Bool -> Class
-              -> RenamedContext        -- class context
-              -> [Name]                -- Names for superclass selectors
-              -> TcM (ThetaType,       -- the superclass context
-                      [Id])            -- superclass selector Ids
-
-tcSuperClasses is_rec gla_exts clas context sc_sel_names
-  = ASSERT( length context == length sc_sel_names )
-       -- Check the context.
-       -- The renamer has already checked that the context mentions
-       -- only the type variable of the class decl.
-
-       -- For std Haskell check that the context constrains only tyvars
-    mapTc_ check_constraint context                    `thenTc_`
-
-       -- Context is already kind-checked
-    tcRecTheta is_rec context          `thenTc` \ sc_theta ->
-    let
-       sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
-    in
-       -- Done
-    returnTc (sc_theta, sc_sel_ids)
-
-  where
-    check_constraint sc = checkTc (ok sc) (superClassErr clas sc)
-    ok (HsClassP c tys) | gla_exts  = True
-                       | otherwise = all is_tyvar tys 
-    ok (HsIParam _ _)  = False         -- Never legal
-
-    is_tyvar (HsTyVar _) = True
-    is_tyvar other      = False
-
-
-tcClassSig :: RecFlag -> RecTcEnv      -- Knot tying only!
-          -> Class                     -- ...ditto...
+tcClassSig :: Class                    -- ...ditto...
           -> [TyVar]                   -- The class type variable, used for error check only
-          -> Maybe (NameEnv Bool)      -- Info about default methods
+          -> Maybe (NameEnv Bool)      -- Info about default methods; 
+                                       --      Nothing => imported class defn with no method binds
           -> RenamedClassOpSig
           -> TcM (Type,                -- Type of the method
                     ClassOpItem)       -- Selector Id, default-method Id, True if explicit default binding
@@ -260,55 +211,79 @@ tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only!
 -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
 -- Class.DefMeth data structure. 
 
-tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
+tcClassSig clas clas_tyvars maybe_dm_env
           (ClassOpSig op_name sig_dm op_ty src_loc)
   = tcAddSrcLoc src_loc $
 
        -- Check the type signature.  NB that the envt *already has*
        -- bindings for the type variables; see comments in TcTyAndClassDcls.
+    tcHsType op_ty                     `thenTc` \ local_ty ->
 
-    tcHsRecType is_rec op_ty                           `thenTc` \ local_ty ->
-
-       -- Check for ambiguous class op types
     let
        theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
-    in
-    checkAmbiguity is_rec True clas_tyvars theta local_ty       `thenTc` \ global_ty ->
-          -- The default method's type should really come from the
-          -- iface file, since it could be usage-generalised, but this
-          -- requires altering the mess of knots in TcModule and I'm
-          -- too scared to do that.  Instead, I have disabled generalisation
-          -- of types of default methods (and dict funs) by annotating them
-          -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.
 
-    let
        -- Build the selector id and default method id
        sel_id = mkDictSelId op_name clas
-       dm_id  = mkDefaultMethodId dm_name global_ty
        DefMeth dm_name = sig_dm
 
        dm_info = case maybe_dm_env of
-                   Nothing     -> iface_dm_info
+                   Nothing     -> sig_dm
                    Just dm_env -> mk_src_dm_info dm_env
 
-       iface_dm_info = case sig_dm of 
-                         NoDefMeth       -> NoDefMeth
-                         GenDefMeth      -> GenDefMeth
-                         DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id)
-
        mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of
                                   Nothing    -> NoDefMeth
                                   Just True  -> GenDefMeth
-                                  Just False -> DefMeth dm_id
+                                  Just False -> DefMeth dm_name
     in
-       -- Check that for a generic method, the type of 
-       -- the method is sufficiently simple
-    checkTc (dm_info /= GenDefMeth || validGenericMethodType local_ty)
-           (badGenericMethodType op_name op_ty)                `thenTc_`
-
     returnTc (local_ty, (sel_id, dm_info))
 \end{code}
 
+checkValidClass is called once the mutually-recursive knot has been
+tied, so we can look at things freely.
+
+\begin{code}
+checkValidClass :: Class -> TcM ()
+checkValidClass cls
+  =    -- CHECK ARITY 1 FOR HASKELL 1.4
+    doptsTc Opt_GlasgowExts                            `thenTc` \ gla_exts ->
+
+       -- Check that the class is unary, unless GlaExs
+    checkTc (not (null tyvars))                (nullaryClassErr cls)   `thenTc_`
+    checkTc (gla_exts || unary) (classArityErr cls)    `thenTc_`
+
+       -- Check the super-classes
+    checkValidTheta (ClassSCCtxt (className cls)) theta        `thenTc_`
+
+       -- Check the class operations
+    mapTc_ check_op op_stuff           `thenTc_`
+
+       -- Check that if the class has generic methods, then the
+       -- class has only one parameter.  We can't do generic
+       -- multi-parameter type classes!
+    checkTc (unary || no_generics) (genericMultiParamErr cls)
+
+  where
+    (tyvars, theta, _, op_stuff) = classBigSig cls
+    unary      = isSingleton tyvars
+    no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+
+    check_op (sel_id, dm) 
+       = checkValidTheta SigmaCtxt (tail theta)        `thenTc_`
+               -- The 'tail' removes the initial (C a) from the
+               -- class itself, leaving just the method type
+
+         checkValidType (FunSigCtxt op_name) tau       `thenTc_`
+
+               -- Check that for a generic method, the type of 
+               -- the method is sufficiently simple
+         checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
+                 (badGenericMethodType op_name op_ty)
+       where
+         op_name = idName sel_id
+         op_ty   = idType sel_id
+         (_,theta,tau) = tcSplitSigmaTy op_ty
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
@@ -375,18 +350,19 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 each local class decl.
 
 \begin{code}
-tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds)
+tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds, [Id])
 
 tcClassDecls2 this_mod decls
   = foldr combine
-         (returnNF_Tc (emptyLIE, EmptyMonoBinds))
+         (returnNF_Tc (emptyLIE, EmptyMonoBinds, []))
          [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls] 
                -- The 'Just' picks out source ClassDecls
   where
-    combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
-                     tc2 `thenNF_Tc` \ (lie2, binds2) ->
+    combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1, ids1) ->
+                     tc2 `thenNF_Tc` \ (lie2, binds2, ids2) ->
                      returnNF_Tc (lie1 `plusLIE` lie2,
-                                  binds1 `AndMonoBinds` binds2)
+                                  binds1 `AndMonoBinds` binds2,
+                                  ids1 ++ ids2)
 \end{code}
 
 @tcClassDecl2@ generates bindings for polymorphic default methods
@@ -394,12 +370,12 @@ tcClassDecls2 this_mod decls
 
 \begin{code}
 tcClassDecl2 :: RenamedTyClDecl                -- The class declaration
-            -> NF_TcM (LIE, TcMonoBinds)
+            -> NF_TcM (LIE, TcMonoBinds, [Id])
 
 tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, 
                         tcdMeths = Just default_binds, tcdLoc = src_loc})
   =    -- The 'Just' picks out source ClassDecls
-    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ 
+    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds, [])) $ 
     tcAddSrcLoc src_loc                                          $
     tcLookupClass class_name                             `thenNF_Tc` \ clas ->
 
@@ -416,13 +392,13 @@ tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs,
        prags                    = filter isPragSig sigs
        tc_dm                    = tcDefMeth clas tyvars default_binds prags
     in
-    mapAndUnzipTc tc_dm op_items       `thenTc` \ (defm_binds, const_lies) ->
+    mapAndUnzip3Tc tc_dm op_items      `thenTc` \ (defm_binds, const_lies, dm_ids_s) ->
 
-    returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
+    returnTc (plusLIEs const_lies, andMonoBindList defm_binds, concat dm_ids_s)
     
 
-tcDefMeth clas tyvars binds_in prags (_, NoDefMeth)  = returnTc (EmptyMonoBinds, emptyLIE)
-tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE)
+tcDefMeth clas tyvars binds_in prags (_, NoDefMeth)  = returnTc (EmptyMonoBinds, emptyLIE, [])
+tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE, [])
        -- Generate code for polymorphic default methods only
        -- (Generic default methods have turned into instance decls by now.)
        -- This is incompatible with Hugs, which expects a polymorphic 
@@ -430,10 +406,22 @@ tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds,
        -- the programmer supplied an explicit default decl for the class.  
        -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 
-tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
-  = tcInstTyVars tyvars                        `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
+tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
+  = tcInstSigTyVars ClsTv tyvars                       `thenNF_Tc` \ clas_tyvars ->
     let
-        theta = [(mkClassPred clas inst_tys)]
+       dm_ty = idType sel_id   -- Same as dict selector!
+          -- The default method's type should really come from the
+          -- iface file, since it could be usage-generalised, but this
+          -- requires altering the mess of knots in TcModule and I'm
+          -- too scared to do that.  Instead, I have disabled generalisation
+          -- of types of default methods (and dict funs) by annotating them
+          -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.
+
+       inst_tys    = mkTyVarTys clas_tyvars
+        theta       = [mkClassPred clas inst_tys]
+       dm_id       = mkDefaultMethodId dm_name dm_ty
+       local_dm_id = setIdLocalExported dm_id
+               -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
     in
     newDicts origin theta              `thenNF_Tc` \ [this_dict] ->
 
@@ -449,20 +437,20 @@ tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
         (ptext SLIT("class") <+> ppr clas)
        clas_tyvars
         [this_dict]
-        insts_needed                           `thenTc` \ (const_lie, dict_binds) ->
+        insts_needed                   `thenTc` \ (const_lie, dict_binds) ->
 
        -- Simplification can do unification
-    checkSigTyVars clas_tyvars emptyVarSet     `thenTc` \ clas_tyvars' ->
+    checkSigTyVars clas_tyvars         `thenTc` \ clas_tyvars' ->
     
     let
         full_bind = AbsBinds
                    clas_tyvars'
                    [instToId this_dict]
-                   [(clas_tyvars', dm_id, instToId local_dm_inst)]
+                   [(clas_tyvars', local_dm_id, instToId local_dm_inst)]
                    emptyNameSet        -- No inlines (yet)
                    (dict_binds `andMonoBinds` defm_bind)
     in
-    returnTc (full_bind, const_lie)
+    returnTc (full_bind, const_lie, [dm_id])
   where
     origin = ClassDeclOrigin
 \end{code}
@@ -505,7 +493,6 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
     let
        meth_id    = instToId meth
        meth_name  = idName meth_id
-       sig_msg    = ptext SLIT("When checking the expected type for class method") <+> ppr sel_id
        meth_prags = find_prags (idName sel_id) meth_name prags
     in
     mkTcSig meth_id loc                        `thenNF_Tc` \ sig_info -> 
@@ -520,11 +507,12 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
     )                                                          `thenTc` \ meth_bind ->
      -- Check the bindings; first add inst_tyvars to the envt
      -- so that we don't quantify over them in nested places
-     -- The *caller* put the class/inst decl tyvars into the envt
-     tcExtendGlobalTyVars (mkVarSet inst_tyvars) 
+     -- The *caller* put the class/inst decl tyvars into the tyvar envt,
+     -- but not into the global tyvars, so that the call to checkSigTyVars below works ok
+     tcExtendGlobalTyVars inst_tyvars 
                    (tcAddErrCtxt (methodCtxt sel_id)           $
                     tcBindWithSigs NotTopLevel meth_bind 
-                    [sig_info] meth_prags NonRecursive 
+                                   [sig_info] meth_prags NonRecursive 
                    )                                           `thenTc` \ (binds, insts, _) -> 
 
      tcExtendLocalValEnv [(meth_name, meth_id)] 
@@ -542,8 +530,10 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
      -- We do this for each method independently to localise error messages
      -- ...and this is why the call to tcExtendGlobalTyVars must be here
      --    rather than in the caller
-     tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id))   $
-     checkSigTyVars inst_tyvars emptyVarSet                                    `thenTc_` 
+     tcAddErrCtxt (ptext SLIT("When checking the type of class method") 
+                  <+> quotes (ppr sel_id))                             $
+     tcAddErrCtxtM (sigCtxt inst_tyvars inst_theta (idType meth_id))   $
+     checkSigTyVars inst_tyvars                                                `thenTc_` 
 
      returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, 
               insts `plusLIE` prag_lie',
@@ -552,9 +542,9 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
      -- The user didn't supply a method binding, 
      -- so we have to make up a default binding
      -- The RHS of a default method depends on the default-method info
-mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id)
+mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_name)
   =  -- An polymorphic default method
-    returnTc (HsVar (idName dm_id))
+    returnTc (HsVar dm_name)
 
 mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
   =    -- No default method
@@ -615,10 +605,8 @@ find_bind sel_name meth_name other  = Nothing      -- Default case
 find_prags sel_name meth_name [] = []
 find_prags sel_name meth_name (SpecSig name ty loc : prags) 
      | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags
-find_prags sel_name meth_name (InlineSig name phase loc : prags)
-   | name == sel_name = InlineSig meth_name phase loc : find_prags sel_name meth_name prags
-find_prags sel_name meth_name (NoInlineSig name phase loc : prags)
-   | name == sel_name = NoInlineSig meth_name phase loc : find_prags sel_name meth_name prags
+find_prags sel_name meth_name (InlineSig sense name phase loc : prags)
+   | name == sel_name = InlineSig sense meth_name phase loc : find_prags sel_name meth_name prags
 find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
 \end{code}
 
@@ -626,12 +614,12 @@ find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
 Contexts and errors
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
-classArityErr class_name
-  = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
+nullaryClassErr cls
+  = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
 
-superClassErr clas sc
-  = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
-    <+> ptext SLIT("in declaration for class") <+> quotes (ppr clas)
+classArityErr cls
+  = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
+         parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
 
 defltMethCtxt clas
   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)