[project @ 1996-05-16 09:42:08 by partain]

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index a48bc1e..d2a63ba 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -23,9 +23,9 @@ import RnHsSyn                ( RenamedClassDecl(..), RenamedClassPragmas(..),
                          RnName{-instance Uniquable-}
                        )
 import TcHsSyn         ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
-                         mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
+                         mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam )
 
-import TcMonad
+import TcMonad         hiding ( rnMtoTcM )
 import Inst            ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
 import TcEnv           ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
 import TcInstDcls      ( processInstBinds )
@@ -35,14 +35,15 @@ import TcType               ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars )
 import TcKind          ( TcKind )
 
 import Bag             ( foldBag )
-import Class           ( GenClass, mkClass, mkClassOp, getClassBigSig, 
-                         getClassOps, getClassOpString, getClassOpLocalType )
-import CoreUtils       ( escErrorMsg )
+import Class           ( GenClass, mkClass, mkClassOp, classBigSig, 
+                         classOps, classOpString, classOpLocalType,
+                         classOpTagByString
+                       )
 import Id              ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
                          idType )
 import IdInfo          ( noIdInfo )
-import Name            ( isLocallyDefined, getOrigName, getLocalName )
-import PrelVals                ( pAT_ERROR_ID )
+import Name            ( isLocallyDefined, moduleNamePair, getLocalName )
+import PrelVals                ( nO_DEFAULT_METHOD_ERROR_ID )
 import PprStyle
 import Pretty
 import PprType         ( GenType, GenTyVar, GenClassOp )
@@ -87,10 +88,11 @@ tcClassDecl1 rec_inst_mapper
                                `thenTc` \ sig_stuff ->
 
        -- MAKE THE CLASS OBJECT ITSELF
-    tcGetUnique                        `thenNF_Tc` \ uniq ->
+-- BOGUS:
+--  tcGetUnique                        `thenNF_Tc` \ uniq ->
     let
        (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
-       clas = mkClass uniq (getName class_name) rec_tyvar
+       clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
                       scs sc_sel_ids ops op_sel_ids defm_ids
                       rec_class_inst_env
     in
@@ -116,7 +118,8 @@ tcClassContext rec_class rec_tyvar context pragmas
 
        -- Make super-class selector ids
     mapTc (mk_super_id rec_class) 
-         (super_classes `zip` maybe_pragmas)   `thenTc` \ sc_sel_ids ->
+         (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
+         -- NB: we worry about matching list lengths below
 
        -- Done
     returnTc (super_classes, sc_sel_ids)
@@ -176,8 +179,9 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
        full_theta  = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
        global_ty   = mkSigmaTy full_tyvars full_theta tau
        local_ty    = mkSigmaTy tyvars theta tau
-       class_op    = mkClassOp (getLocalName op_name)
-                               (panic "(getTagFromClassOpName op_name)TcClassDecl"{-(getTagFromClassOpName op_name)-})
+       class_op_nm = getLocalName op_name
+       class_op    = mkClassOp class_op_nm
+                               (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
                                local_ty
     in
 
@@ -259,7 +263,7 @@ tcClassDecl2 (ClassDecl context class_name
     tcLookupClass class_name           `thenNF_Tc` \ (_, clas) ->
     let
        (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
-         = getClassBigSig clas
+         = classBigSig clas
     in
     tcInstSigTyVars [tyvar]            `thenNF_Tc` \ ([clas_tyvar], _, _) ->
 
@@ -292,10 +296,10 @@ buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
        -- Make new Ids for the components of the dictionary
     let
        clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
-       mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . getClassOpLocalType 
+       mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType 
     in
     mapNF_Tc mk_op_ty ops                              `thenNF_Tc` \ op_tys ->
-    newLocalIds (map getClassOpString ops) op_tys      `thenNF_Tc` \ method_ids ->
+    newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids ->
 
     newDicts ClassDeclOrigin 
             [ (super_clas, clas_tyvar_ty)
@@ -309,8 +313,8 @@ buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
        mk_sel sel_id method_or_dict
          = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
     in
-    listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
-    listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids)   `thenNF_Tc` \ sc_sel_binds ->
+    listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
+    listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids)   `thenNF_Tc` \ sc_sel_binds ->
 
     returnNF_Tc (SingleBind (
                 NonRecBind (
@@ -471,12 +475,12 @@ buildDefaultMethodBinds
 buildDefaultMethodBinds clas clas_tyvar
                        default_method_ids default_binds
   =    -- Deal with the method declarations themselves
-    mapNF_Tc unZonkId default_method_ids       `thenNF_Tc` \ tc_defm_ids ->
     processInstBinds
+        clas
         (makeClassDeclDefaultMethodRhs clas default_method_ids)
         []             -- No tyvars in scope for "this inst decl"
         emptyLIE       -- No insts available
-        (map TcId tc_defm_ids)
+        (map RealId default_method_ids)
         default_binds          `thenTc` \ (dicts_needed, default_binds') ->
 
     returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
@@ -501,21 +505,17 @@ makeClassDeclDefaultMethodRhs clas method_ids tag
 
     returnNF_Tc (mkHsTyLam tyvars (
                 mkHsDictLam dict_ids (
-                HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
+                HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
                     (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
   where
-    (clas_mod, clas_name) = getOrigName clas
+    (clas_mod, clas_name) = moduleNamePair clas
 
     method_id = method_ids  !! (tag-1)
-    class_op = (getClassOps clas) !! (tag-1)
-
-    error_msg = "%D" -- => No default method for \"
-            ++ unencoded_part_of_msg
+    class_op = (classOps clas) !! (tag-1)
 
-    unencoded_part_of_msg = escErrorMsg (
-       _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
-            ++ (ppShow 80 (ppr PprForUser class_op))
-            ++ "\"" )
+    error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
+                ++ (ppShow 80 (ppr PprForUser class_op))
+                ++ "\""
 \end{code}