[project @ 1996-01-18 16:33:17 by partain]

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

diff --git a/ghc/compiler/typecheck/TcClassSig.lhs b/ghc/compiler/typecheck/TcClassSig.lhs
index cec1789..e3637af 100644 (file)
--- a/ghc/compiler/typecheck/TcClassSig.lhs
+++ b/ghc/compiler/typecheck/TcClassSig.lhs
@@ -29,13 +29,14 @@ import Util
 tcClassSigs :: E -> TVE -> Class       -- Knot tying only!
            -> (ClassOp -> SpecEnv)     -- Ditto; the spec info for the class ops
            -> TyVarTemplate            -- The class type variable, used for error check only
+           -> [Name]                   -- Names with default methods
            -> [RenamedClassOpSig]
            -> Baby_TcM ([ClassOp],     -- class ops
                         GVE,           -- env for looking up the class ops
                         [Id],          -- selector ids
                         [Id])          -- default-method ids
 
-tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar sigs
+tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
   = mapB_Tc tc_sig sigs        `thenB_Tc` \ stuff ->
     let
        (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
@@ -44,26 +45,10 @@ tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar sigs
   where
     rec_ce  = getE_CE  e
     rec_tce = getE_TCE e
---FAKE:    fake_E  = mkE rec_tce rec_ce
 
-    tc_sig (ClassOpSig name@(ClassOpName op_uniq _ op_name tag) poly_ty pragmas src_loc)
+    tc_sig (ClassOpSig name@(ClassOpName op_uniq clas_name op_name tag) poly_ty pragmas src_loc)
       = addSrcLocB_Tc src_loc                           (
        tcPolyType rec_ce rec_tce tve poly_ty   `thenB_Tc` \ local_ty ->
-
---             OLD: convoluted way to compute global_ty
---     let
---         (local_tyvar_tmpls, theta, tau) = splitType local_ty
---     in
---         -- Make new tyvars for each of the universally quantified type vars
---     copyTyVars (clas_tyvar:local_tyvar_tmpls)
---                             `thenB_Tc` \ (inst_env, new_tyvars, _) ->
---
---     let -- Instantiate the tau type
---         full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
---         full_rho = mkRhoTy full_theta tau
---         inst_full_rho = instantiateTy inst_env full_rho
---         (_, global_ty) = quantifyTy new_tyvars inst_full_rho
-
        let
            (local_tyvar_tmpls, theta, tau) = splitType local_ty
            full_theta       = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
@@ -87,10 +72,18 @@ tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar sigs
                rec_op_id rec_defm_id
                (rec_classop_spec_fn class_op)
                pragmas         `thenB_Tc` \ (op_info, defm_info) ->
-
+           let
+               -- the default method is error "No default ..." if there is no
+               -- default method code or the imported default method is bottoming.
+
+               error_defm = if isLocallyDefined clas_name then
+                                name `notElem` defm_names 
+                            else 
+                                bottomIsGuaranteed (getInfo defm_info)
+           in
            returnB_Tc (
              mkClassOpId      op_uniq rec_clas class_op global_ty op_info,
-             mkDefaultMethodId d_uniq rec_clas class_op False{-do better later-} global_ty defm_info
+             mkDefaultMethodId d_uniq rec_clas class_op error_defm global_ty defm_info
            )
 
        ) `thenB_Tc` \ (selector_id, default_method_id) ->