[project @ 1996-07-19 18:36:04 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 0393618..fea81a4 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -6,61 +6,59 @@
 \begin{code}
 #include "HsVersions.h"
 
-module TcClassDcl (
-       tcClassDecl1, tcClassDecls2
-    ) where
+module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
 
 IMP_Ubiq()
 
 import HsSyn           ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
                          Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
                          HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType, 
-                         Stmt, Qual, ArithSeqInfo, InPat, Fake )
+                         Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
 import HsPragmas       ( ClassPragmas(..) )
 import RnHsSyn         ( RenamedClassDecl(..), RenamedClassPragmas(..),
-                         RenamedClassOpSig(..), RenamedMonoBinds(..),
+                         RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
                          RenamedGenPragmas(..), RenamedContext(..),
                          RnName{-instance Uniquable-}
                        )
-import TcHsSyn         ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
+import TcHsSyn         ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
                          mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
 
-import Inst            ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
-import TcEnv           ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
-import TcInstDcls      ( processInstBinds, newMethodId )
-import TcKind          ( TcKind )
-import TcKind          ( unifyKind )
+import Inst            ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
+import TcEnv           ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
+import TcInstDcls      ( processInstBinds )
+import TcKind          ( unifyKind, TcKind )
 import TcMonad         hiding ( rnMtoTcM )
 import TcMonoType      ( tcPolyType, tcMonoType, tcContext )
 import TcSimplify      ( tcSimplifyAndCheck )
-import TcType          ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars, tcInstSigType )
+import TcType          ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
 
 import Bag             ( foldBag, unionManyBags )
 import Class           ( GenClass, mkClass, mkClassOp, classBigSig, 
                          classOps, classOpString, classOpLocalType,
-                         classOpTagByString
+                         classOpTagByString, SYN_IE(ClassOp)
                        )
 import Id              ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
                          idType )
-import IdInfo          ( noIdInfo )
-import Name            ( isLocallyDefined, moduleNamePair, getLocalName )
+import IdInfo
+import Name            ( isLocallyDefined, origName, getLocalName )
 import PrelVals                ( nO_DEFAULT_METHOD_ERROR_ID )
 import PprStyle
 import Pretty
 import PprType         ( GenType, GenTyVar, GenClassOp )
-import SpecEnv         ( SpecEnv(..) )
+import SpecEnv         ( SpecEnv )
 import SrcLoc          ( mkGeneratedSrcLoc )
 import Type            ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
                          mkForAllTy, mkSigmaTy, splitSigmaTy)
 import TysWiredIn      ( stringTy )
-import TyVar           ( mkTyVarSet, GenTyVar )
+import TyVar           ( unitTyVarSet, GenTyVar )
 import Unique          ( Unique )                       
 import Util
 
 
 -- import TcPragmas    ( tcGenPragmas, tcClassOpPragmas )
 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec, 
+                                                  noIdInfo)
 \end{code}
 
 
@@ -551,20 +549,22 @@ buildDefaultMethodBinds clas clas_tyvar
   = newDicts origin [(clas,inst_ty)]                   `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
     mapAndUnzipNF_Tc mk_method default_method_ids      `thenNF_Tc` \ (insts_s, local_defm_ids) ->
     let
-       avail_insts = this_dict `plusLIE` unionManyBags insts_s         -- Insts available
+       avail_insts    = this_dict `plusLIE` unionManyBags insts_s      -- Insts available
+       clas_tyvar_set = unitTyVarSet clas_tyvar
     in
-    processInstBinds
-        clas
-        (makeClassDeclDefaultMethodRhs clas local_defm_ids)
-        [clas_tyvar]   -- Tyvars in scope
-        avail_insts
-        local_defm_ids
-        default_binds                                  `thenTc` \ (insts_needed, default_binds') ->
+    tcExtendGlobalTyVars clas_tyvar_set (
+       processInstBinds
+          clas
+          (makeClassDeclDefaultMethodRhs clas local_defm_ids)
+          avail_insts
+          local_defm_ids
+          default_binds
+    )                                  `thenTc` \ (insts_needed, default_binds') ->
 
     tcSimplifyAndCheck
-       (mkTyVarSet [clas_tyvar])
+       clas_tyvar_set
        avail_insts
-       insts_needed                                    `thenTc` \ (const_lie, dict_binds) ->
+       insts_needed                    `thenTc` \ (const_lie, dict_binds) ->
        
 
     let
@@ -578,7 +578,7 @@ buildDefaultMethodBinds clas clas_tyvar
     returnTc (const_lie, defm_binds)
   where
     inst_ty = mkTyVarTy clas_tyvar
-    mk_method defm_id = newMethodId defm_id inst_ty origin
+    mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty]
     origin = ClassDeclOrigin
 \end{code}
 
@@ -615,7 +615,7 @@ makeClassDeclDefaultMethodRhs clas method_ids tag
 -}
 
   where
-    (clas_mod, clas_name) = moduleNamePair clas
+    (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas
 
     method_id = method_ids  !! (tag-1)
     class_op  = (classOps clas) !! (tag-1)