[project @ 1996-05-01 18:36:59 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..08e2fe1 100644 (file)
--- a/ghc/compiler/typecheck/TcClassSig.lhs
+++ b/ghc/compiler/typecheck/TcClassSig.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcClassSig]{Typecheck a class signature}
 
@@ -8,19 +8,13 @@
 
 module TcClassSig ( tcClassSigs ) where
 
-import TcMonad         -- typechecking monadic machinery
-import AbsSyn          -- the stuff being typechecked
+import TcMonad         hiding ( rnMtoTcM )
+import HsSyn           -- the stuff being typechecked
 
-import AbsUniType
-import CE              ( CE(..) )
-import E               ( mkE, getE_TCE, getE_CE, nullGVE, unitGVE, plusGVE, GVE(..), E )
-import Errors          ( methodTypeLacksTyVarErr, confusedNameErr )
+import Type
 import Id              ( mkDefaultMethodId, mkClassOpId, IdInfo )
 import IdInfo
-import InstEnv         ( InstTemplate )
-import TCE             ( TCE(..), UniqFM )
-import TVE             ( TVE(..) )
-import TcPolyType      ( tcPolyType )
+import TcMonoType      ( tcPolyType )
 import TcPragmas       ( tcClassOpPragmas )
 import Util
 \end{code}
@@ -29,13 +23,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
+           -> [RnName]                 -- 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
+                        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
@@ -49,23 +44,8 @@ tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar sigs
     tc_sig (ClassOpSig name@(ClassOpName op_uniq _ 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
+           (local_tyvar_tmpls, theta, tau) = splitSigmaTy local_ty
            full_theta       = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
            full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls
            global_ty        = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau)
@@ -87,10 +67,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) ->