X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=fea81a43da4da9e2e61f3dcfdb07f611be4ae345;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=039361851b96cf25e8132ea79d2df4a3872acb67;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 0393618..fea81a4 100644
--- 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)