[project @ 1998-12-02 13:17:09 by simonm]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcClassDcl.lhs
index 5e555ff..be9a073 100644 (file)
@@ -1,73 +1,68 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcClassDcl]{Typechecking class declarations}
 
 \begin{code}
-#include "HsVersions.h"
-
-module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
+module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
 
-IMP_Ubiq()
+#include "HsVersions.h"
 
-import HsSyn           ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..),
-                         Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), 
-                         DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
-                         HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
-                         SYN_IE(RecFlag), nonRecursive, andMonoBinds, collectMonoBinders,
-                         Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake )
-import HsTypes         ( getTyVarName )
+import HsSyn           ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
+                         InPat(..), HsBinds(..), GRHSsAndBinds(..),
+                         HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
+                         unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName
+                       )
 import HsPragmas       ( ClassPragmas(..) )
-import RnHsSyn         ( RenamedClassDecl(..), RenamedClassPragmas(..),
-                         RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
-                         RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl)
+import BasicTypes      ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
+import RnHsSyn         ( RenamedClassDecl, RenamedClassPragmas,
+                         RenamedClassOpSig, RenamedMonoBinds,
+                         RenamedContext, RenamedHsDecl, RenamedSig
+                       )
+import TcHsSyn         ( TcMonoBinds )
+
+import Inst            ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
+import TcEnv           ( TcIdOcc(..), GlobalValueEnv, tcAddImportedIdInfo,
+                         tcLookupClass, tcLookupTyVar, 
+                         tcExtendGlobalTyVars, tcExtendLocalValEnv
                        )
-import TcHsSyn         ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
-                         mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
-
-import Inst            ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
-import TcEnv           ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo,
-                         tcExtendGlobalTyVars )
-import TcBinds         ( tcBindWithSigs, TcSigInfo(..) )
-import TcKind          ( unifyKind, TcKind )
+import TcBinds         ( tcBindWithSigs, tcPragmaSigs )
+import TcUnify         ( unifyKinds )
 import TcMonad
-import TcMonoType      ( tcHsType, tcContext )
-import TcSimplify      ( tcSimplifyAndCheck )
-import TcType          ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, 
-                         tcInstSigType, tcInstSigTcType )
-import PragmaInfo      ( PragmaInfo(..) )
-
-import Bag             ( bagToList )
-import Class           ( GenClass, mkClass, classBigSig, 
-                         classDefaultMethodId,
-                         classOpTagByOccName, SYN_IE(Class)
+import TcMonoType      ( tcHsType, tcContext, checkSigTyVars, sigCtxt, mkTcSig )
+import TcSimplify      ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
+import TcType          ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr )
+import PrelVals                ( nO_METHOD_BINDING_ERROR_ID )
+import FieldLabel      ( firstFieldLabelTag )
+import Bag             ( unionManyBags )
+import Class           ( mkClass, classBigSig, Class )
+import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
+import MkId            ( mkSuperDictSelId, mkDataConId,
+                         mkMethodSelId, mkDefaultMethodId
                        )
-import CmdLineOpts      ( opt_PprUserLength )
-import Id              ( GenId, mkSuperDictSelId, mkMethodSelId, 
-                         mkDefaultMethodId, getIdUnfolding,
-                         idType, SYN_IE(Id)
+import DataCon         ( mkDataCon )
+import Id              ( Id,
+                         getIdUnfolding, idType, idName
                        )
 import CoreUnfold      ( getUnfoldingTemplate )
 import IdInfo
-import Name            ( Name, isLocallyDefined, moduleString, getSrcLoc,
-                         nameString, NamedThing(..) )
+import Name            ( Name, isLocallyDefined, NamedThing(..) )
 import Outputable
-import Pretty
-import PprType         ( GenClass, GenType, GenTyVar )
-import SpecEnv         ( SpecEnv )
-import SrcLoc          ( mkGeneratedSrcLoc )
-import Type            ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
-                         mkForAllTy, mkSigmaTy, splitSigmaTy, SYN_IE(Type)
+import Type            ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+                         mkSigmaTy, mkForAllTys, Type, ThetaType,
+                         boxedTypeKind, mkArrowKind
                        )
-import TysWiredIn      ( stringTy )
-import TyVar           ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
+import Var             ( tyVarKind, TyVar )
+import VarSet          ( mkVarSet )
+import TyCon           ( mkAlgTyCon )
 import Unique          ( Unique, Uniquable(..) )
 import Util
+import Maybes          ( seqMaybe )
 
 
 -- import TcPragmas    ( tcGenPragmas, tcClassOpPragmas )
 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec, 
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo, 
                                                   noIdInfo)
 \end{code}
 
@@ -109,107 +104,135 @@ Death to "ExpandingDicts".
 \begin{code}
 tcClassDecl1 rec_env rec_inst_mapper
             (ClassDecl context class_name
-                       tyvar_name class_sigs def_methods pragmas src_loc)
+                       tyvar_names class_sigs def_methods pragmas 
+                       tycon_name datacon_name src_loc)
   = tcAddSrcLoc src_loc        $
     tcAddErrCtxt (classDeclCtxt class_name) $
 
+        -- CHECK ARITY 1 FOR HASKELL 1.4
+    checkTc (opt_GlasgowExts || length tyvar_names == 1)
+           (classArityErr class_name)          `thenTc_`
+
        -- LOOK THINGS UP IN THE ENVIRONMENT
-    tcLookupClass class_name                   `thenTc` \ (class_kind, rec_class) ->
-    tcLookupTyVar (getTyVarName tyvar_name)    `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
-    let
-       rec_class_inst_env = rec_inst_mapper rec_class
-    in
+    tcLookupClass class_name                   `thenTc` \ (class_kinds, rec_class) ->
+    mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_names
+                                               `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 
        -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
-    unifyKind class_kind tyvar_kind    `thenTc_`
+    unifyKinds class_kinds tyvar_kinds `thenTc_`
 
        -- CHECK THE CONTEXT
-    tcClassContext rec_class rec_tyvar context pragmas 
-                               `thenTc` \ (scs, sc_sel_ids) ->
+    tcClassContext class_name rec_class rec_tyvars context pragmas     
+                                               `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 
        -- CHECK THE CLASS SIGNATURES,
-    mapTc (tcClassSig rec_env rec_class rec_tyvar) class_sigs
-                               `thenTc` \ sig_stuff ->
+    mapTc (tcClassSig rec_env rec_class rec_tyvars) class_sigs
+                                               `thenTc` \ sig_stuff ->
 
        -- MAKE THE CLASS OBJECT ITSELF
     let
-       (op_sel_ids, defm_ids) = unzip sig_stuff
-       clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
-                      scs sc_sel_ids op_sel_ids defm_ids
+       (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
+       rec_class_inst_env = rec_inst_mapper rec_class
+       clas = mkClass (getName class_name) rec_tyvars
+                      sc_theta sc_sel_ids op_sel_ids defm_ids
+                      tycon
                       rec_class_inst_env
-    in
-    returnTc clas
-\end{code}
-
 
-    let
-       clas_ty = mkTyVarTy clas_tyvar
-       dict_component_tys = classDictArgTys clas_ty
+       dict_component_tys = sc_tys ++ op_tys
        new_or_data = case dict_component_tys of
                        [_]   -> NewType
                        other -> DataType
 
-        dict_con_id = mkDataCon class_name
-                          [NotMarkedStrict]
+        dict_con = mkDataCon datacon_name
+                          [NotMarkedStrict | _ <- dict_component_tys]
                           [{- No labelled fields -}]
-                          [clas_tyvar]
+                          rec_tyvars
                           [{-No context-}]
+                          [{-No existential tyvars-}] [{-Or context-}]
                           dict_component_tys
-                          tycon
-
-       tycon = mkDataTyCon class_name
-                           (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
-                           [rec_tyvar]
-                           [{- Empty context -}]
-                           [dict_con_id]
-                           [{- No derived classes -}]
+                          tycon dict_con_id
+       dict_con_id = mkDataConId dict_con
+
+       tycon = mkAlgTyCon tycon_name
+                           (foldr (mkArrowKind . tyVarKind) boxedTypeKind rec_tyvars)
+                           rec_tyvars
+                           []                  -- No context
+                           [dict_con]          -- Constructors
+                           []                  -- No derivings
+                           (Just clas)         -- Yes!  It's a dictionary 
                            new_or_data
+                           NonRecursive
     in
+    returnTc clas
+\end{code}
 
 
 \begin{code}
-tcClassContext :: Class -> TyVar
+tcClassContext :: Name -> Class -> [TyVar]
               -> RenamedContext        -- class context
               -> RenamedClassPragmas   -- pragmas for superclasses  
-              -> TcM s ([Class],       -- the superclasses
-                        [Id])          -- superclass selector Ids
+              -> TcM s (ThetaType,     -- the superclass context
+                        [Type],        -- types of the superclass dictionaries
+                        [Id])          -- superclass selector Ids
 
-tcClassContext rec_class rec_tyvar context pragmas
+tcClassContext class_name rec_class rec_tyvars context pragmas
   =    -- Check the context.
        -- The renamer has already checked that the context mentions
        -- only the type variable of the class decl.
-    tcContext context                  `thenTc` \ theta ->
+
+       -- For std Haskell check that the context constrains only tyvars
+    (if opt_GlasgowExts then
+       returnTc []
+     else
+       mapTc check_constraint context
+    )                                  `thenTc_`
+
+    tcContext context                  `thenTc` \ sc_theta ->
+
     let
-      super_classes = [ supers | (supers, _) <- theta ]
+       sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
     in
 
        -- Make super-class selector ids
-    mapTc (mk_super_id rec_class) super_classes        `thenTc` \ sc_sel_ids ->
+       -- We number them off, 1, 2, 3 etc so that we can construct
+       -- names for the selectors.  Thus
+       --      class (C a, C b) => D a b where ...
+       -- gives superclass selectors
+       --      D_sc1, D_sc2
+       -- (We used to call them D_C, but now we can have two different
+       --  superclasses both called C!)
+    mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..])  `thenTc` \ sc_sel_ids ->
 
        -- Done
-    returnTc (super_classes, sc_sel_ids)
+    returnTc (sc_theta, sc_tys, sc_sel_ids)
 
   where
-    rec_tyvar_ty = mkTyVarTy rec_tyvar
+    rec_tyvar_tys = mkTyVarTys rec_tyvars
 
-    mk_super_id rec_class super_class
+    mk_super_id ((super_class, tys), index)
         = tcGetUnique                  `thenNF_Tc` \ uniq ->
          let
-               ty = mkForAllTy rec_tyvar $
-                    mkFunTy (mkDictTy rec_class   rec_tyvar_ty)
-                            (mkDictTy super_class rec_tyvar_ty)
+               ty = mkForAllTys rec_tyvars $
+                    mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
          in
-         returnTc (mkSuperDictSelId uniq rec_class super_class ty)
+         returnTc (mkSuperDictSelId uniq rec_class index ty)
+
+    check_constraint (c, tys) = checkTc (all is_tyvar tys)
+                                       (superClassErr class_name (c, tys))
+
+    is_tyvar (MonoTyVar _) = True
+    is_tyvar other        = False
 
 
-tcClassSig :: TcEnv s                  -- Knot tying only!
+tcClassSig :: GlobalValueEnv           -- Knot tying only!
           -> Class                     -- ...ditto...
-          -> TyVar                     -- The class type variable, used for error check only
+          -> [TyVar]                   -- The class type variable, used for error check only
           -> RenamedClassOpSig
-          -> TcM s (Id,                -- selector id
+          -> TcM s (Type,              -- Type of the method
+                    Id,                -- selector id
                     Maybe Id)          -- default-method ids
 
-tcClassSig rec_env rec_clas rec_clas_tyvar
+tcClassSig rec_env rec_clas rec_clas_tyvars
           (ClassOpSig op_name maybe_dm_name
                       op_ty
                       src_loc)
@@ -222,8 +245,8 @@ tcClassSig rec_env rec_clas rec_clas_tyvar
     -- and that it is not constrained by theta
     tcHsType op_ty                             `thenTc` \ local_ty ->
     let
-       global_ty   = mkSigmaTy [rec_clas_tyvar] 
-                               [(rec_clas, mkTyVarTy rec_clas_tyvar)]
+       global_ty   = mkSigmaTy rec_clas_tyvars 
+                               [(rec_clas, mkTyVarTys rec_clas_tyvars)]
                                local_ty
     in
 
@@ -237,7 +260,7 @@ tcClassSig rec_env rec_clas rec_clas_tyvar
                                           in
                                           Just (tcAddImportedIdInfo rec_env dm_id)
     in
-    returnTc (sel_id, maybe_dm_id)
+    returnTc (local_ty, sel_id, maybe_dm_id)
 \end{code}
 
 
@@ -285,7 +308,7 @@ tcClassDecl2 :: RenamedClassDecl    -- The class declaration
             -> NF_TcM s (LIE s, TcMonoBinds s)
 
 tcClassDecl2 (ClassDecl context class_name
-                       tyvar_name class_sigs default_binds pragmas src_loc)
+                       tyvar_names class_sigs default_binds pragmas _ _ src_loc)
 
   | not (isLocallyDefined class_name)
   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
@@ -297,21 +320,22 @@ tcClassDecl2 (ClassDecl context class_name
        -- Get the relevant class
     tcLookupClass class_name           `thenTc` \ (_, clas) ->
     let
-       (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
+       (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 
        -- The selector binds are already in the selector Id's unfoldings
-       sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
-                   | sel_id <- sc_sel_ids ++ op_sel_ids, 
-                     isLocallyDefined sel_id
-                   ]
-
-       final_sel_binds = andMonoBinds sel_binds
+--     sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
+--                 | sel_id <- sc_sel_ids ++ op_sel_ids, 
+--                   isLocallyDefined sel_id
+--                 ]
+--
+--     final_sel_binds = andMonoBindList sel_binds
     in
        -- Generate bindings for the default methods
-    buildDefaultMethodBinds clas default_binds         `thenTc` \ (const_insts, meth_binds) ->
+    tcDefaultMethodBinds clas default_binds            `thenTc` \ (const_insts, meth_binds) ->
 
-    returnTc (const_insts, 
-             final_sel_binds `AndMonoBinds` meth_binds)
+    returnTc (const_insts, meth_binds)
+--           final_sel_binds `AndMonoBinds` meth_binds)
+-- Leave 'em out for now.  They always get inlined anyway.  SLPJ June '98
 \end{code}
 
 %************************************************************************
@@ -388,69 +412,203 @@ dfun.Foo.List
 \end{verbatim}
 
 \begin{code}
-buildDefaultMethodBinds
+tcDefaultMethodBinds
        :: Class
        -> RenamedMonoBinds
        -> TcM s (LIE s, TcMonoBinds s)
 
-buildDefaultMethodBinds clas default_binds
+tcDefaultMethodBinds clas default_binds
   =    -- Construct suitable signatures
-    tcInstSigTyVars [tyvar]            `thenNF_Tc` \ ([clas_tyvar], [inst_ty], inst_env) ->
-    let
-       mk_sig (bndr_name, locn)
-         = let
-               idx        = classOpTagByOccName clas (getOccName bndr_name) - 1
-               sel_id     = op_sel_ids !! idx
-               Just dm_id = defm_ids !! idx
-           in
-           newMethod origin (RealId sel_id) [inst_ty]  `thenNF_Tc` \ meth@(_, TcId local_dm_id) ->
-           tcInstSigTcType (idType local_dm_id)        `thenNF_Tc` \ (tyvars', rho_ty') ->
-           let
-               (theta', tau') = splitRhoTy rho_ty'
-               sig_info       = TySigInfo bndr_name local_dm_id tyvars' theta' tau' locn
-           in
-           returnNF_Tc (sig_info, ([clas_tyvar], RealId dm_id, TcId local_dm_id))
-    in
-    mapAndUnzipNF_Tc mk_sig bndrs      `thenNF_Tc` \ (sigs, abs_bind_stuff) ->
+    tcInstTyVars tyvars                `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
 
        -- Typecheck the default bindings
     let
-       clas_tyvar_set    = unitTyVarSet clas_tyvar
-    in
-    tcExtendGlobalTyVars clas_tyvar_set (
-       tcBindWithSigs (map fst bndrs) default_binds sigs nonRecursive (\_ -> NoPragmaInfo)
-    )                                          `thenTc` \ (defm_binds, insts_needed, _) ->
+       tc_dm sel_id_w_dm@(_, Just dm_id)
+         = tcMethodBind clas origin inst_tys clas_tyvars 
+                        default_binds [{-no prags-}] False
+                        sel_id_w_dm            `thenTc` \ (bind, insts, (_, local_dm_id)) ->
+           returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
+    in    
+    mapAndUnzip3Tc tc_dm sel_ids_w_dms         `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 
        -- Check the context
-    newDicts origin [(clas,inst_ty)]           `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+    newDicts origin [(clas,inst_tys)]          `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
     let
-       avail_insts   = this_dict
+       avail_insts = this_dict
     in
+    tcAddErrCtxt (classDeclCtxt clas) $
+
+       -- tcMethodBind has checked that the class_tyvars havn't
+       -- been unified with each other or another type, but we must
+       -- still zonk them
+    mapNF_Tc zonkTcTyVarBndr clas_tyvars       `thenNF_Tc` \ clas_tyvars' ->
+
     tcSimplifyAndCheck
-       clas_tyvar_set
+       (ptext SLIT("class") <+> ppr clas)
+       (mkVarSet clas_tyvars')
        avail_insts
-       insts_needed                    `thenTc` \ (const_lie, dict_binds) ->
+       (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 
     let
        full_binds = AbsBinds
-                       [clas_tyvar]
+                       clas_tyvars'
                        [this_dict_id]
                        abs_bind_stuff
-                       (dict_binds `AndMonoBinds` defm_binds)
+                       (dict_binds `andMonoBinds` andMonoBindList defm_binds)
     in
     returnTc (const_lie, full_binds)
 
   where
-    (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
+    (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
+
+    sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
+                       -- Just the ones for which there is an explicit
+                       -- user default declaration
+
     origin = ClassDeclOrigin
-    bndrs  = bagToList (collectMonoBinders default_binds)
 \end{code}
 
+@tcMethodBind@ is used to type-check both default-method and
+instance-decl method declarations.  We must type-check methods one at a
+time, because their signatures may have different contexts and
+tyvar sets.
 
+\begin{code}
+tcMethodBind 
+       :: Class
+       -> InstOrigin s
+       -> [TcType s]           -- Instance types
+       -> [TcTyVar s]          -- Free variables of those instance types
+                               --  they'll be signature tyvars, and we
+                               --  want to check that they don't bound
+       -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
+       -> [RenamedSig]         -- Pramgas (just for this one)
+       -> Bool                 -- True <=> supply default decl if no explicit decl
+                               --              This is true for instance decls, 
+                               --              false for class decls
+       -> (Id, Maybe Id)       -- The method selector and default-method Id
+       -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
+
+tcMethodBind clas origin inst_tys inst_tyvars 
+            meth_binds prags supply_default_bind
+            (sel_id, maybe_dm_id)
+ = tcGetSrcLoc                 `thenNF_Tc` \ loc -> 
+
+   newMethod origin (RealId sel_id) inst_tys   `thenNF_Tc` \ meth@(_, TcId meth_id) ->
+   mkTcSig meth_id loc                         `thenNF_Tc` \ sig_info -> 
+
+   let
+     meth_name      = idName meth_id
+     maybe_user_bind = find_bind meth_name meth_binds
+
+     no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
+     no_user_default = case maybe_dm_id     of {Nothing -> True; other -> False}
+
+     meth_bind = case maybe_user_bind of
+                       Just bind -> bind
+                       Nothing   -> mk_default_bind meth_name loc
+
+     meth_prags = find_prags meth_name prags
+   in
+
+       -- Warn if no method binding, only if -fwarn-missing-methods
+   if no_user_bind && not supply_default_bind then
+       pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
+   else
+   warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
+         (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
+
+       -- Check the pragmas
+   tcExtendLocalValEnv [meth_name] [meth_id] (
+       tcPragmaSigs meth_prags
+   )                                           `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
+
+       -- Check the bindings
+   tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
+     tcAddErrCtxt (methodCtxt sel_id)          $
+     tcBindWithSigs NotTopLevel meth_bind [sig_info]
+                   NonRecursive prag_info_fn   
+   )                                                   `thenTc` \ (binds, insts, _) ->
+
+
+       -- The prag_lie for a SPECIALISE pragma will mention the function
+       -- itself, so we have to simplify them away right now lest they float
+       -- outwards!
+   bindInstsOfLocalFuns prag_lie [meth_id]     `thenTc` \ (prag_lie', prag_binds2) ->
+
+
+       -- Now check that the instance type variables
+       -- (or, in the case of a class decl, the class tyvars)
+       -- have not been unified with anything in the environment
+   tcAddErrCtxtM (sigCtxt (quotes (ppr sel_id)) (idType meth_id))      (
+   checkSigTyVars inst_tyvars                                          `thenTc_` 
+
+   returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, 
+            insts `plusLIE` prag_lie', 
+            meth))
+
+ where
+   sel_name = idName sel_id
+
+       -- The renamer just puts the selector ID as the binder in the method binding
+       -- but we must use the method name; so we substitute it here.  Crude but simple.
+   find_bind meth_name (FunMonoBind op_name fix matches loc)
+       | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
+   find_bind meth_name (PatMonoBind (VarPatIn op_name) rhs loc)
+       | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) rhs loc)
+   find_bind meth_name (AndMonoBinds b1 b2)
+                             = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
+   find_bind meth_name other  = Nothing        -- Default case
+
+
+       -- Find the prags for this method, and replace the
+       -- selector name with the method name
+   find_prags meth_name [] = []
+   find_prags meth_name (SpecSig name ty spec loc : prags)
+       | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
+   find_prags meth_name (InlineSig name loc : prags)
+       | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
+   find_prags meth_name (NoInlineSig name loc : prags)
+       | name == sel_name = NoInlineSig meth_name loc : find_prags meth_name prags
+   find_prags meth_name (prag:prags) = find_prags meth_name prags
+
+   mk_default_bind local_meth_name loc
+      = PatMonoBind (VarPatIn local_meth_name)
+                   (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
+                   loc
+
+   default_expr loc 
+      = case maybe_dm_id of
+         Just dm_id -> HsVar (getName dm_id)   -- There's a default method
+         Nothing    -> error_expr loc          -- No default method
+
+   error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
+                         (HsLit (HsString (_PK_ (error_msg loc))))
+
+   error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+\end{code}
 
-Contexts
-~~~~~~~~
+Contexts and errors
+~~~~~~~~~~~~~~~~~~~
 \begin{code}
-classDeclCtxt class_name sty
-  = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]
+classArityErr class_name
+  = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
+
+classDeclCtxt class_name
+  = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
+
+superClassErr class_name sc
+  = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
+    <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
+
+methodCtxt sel_id
+  = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
+
+badMethodErr bndr clas
+  = hsep [ptext SLIT("Class"), quotes (ppr clas), 
+         ptext SLIT("does not have a method"), quotes (ppr bndr)]
+
+omittedMethodWarn sel_id clas
+  = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id), 
+        ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 \end{code}