X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcClassDcl.lhs;h=92c7958d26c6fd975ce651b65469f9bf1377e82c;hb=2423c249f5ca7785d0ec89eb33e72662da7561c1;hp=25795cef9a6fe3243600f964da8d92a1ee37dea3;hpb=15cb792d18b1094e98c035dca6ecec5dad516056;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 25795ce..92c7958 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -1,72 +1,61 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[TcClassDcl]{Typechecking class declarations}
+
+Typechecking class declarations
 
 \begin{code}
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
 		    getGenericInstances, 
 		    MethodSpec, tcMethodBind, mkMethodBind, 
-		    tcAddDeclCtxt, badMethodErr
+		    tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
 		  ) where
 
 #include "HsVersions.h"
 
 import HsSyn
-import RnHsSyn		( maybeGenericMatch, extractHsTyVars )
-import RnExpr		( rnLExpr )
-import RnEnv		( lookupTopBndrRn, lookupImportedName )
-import Inst		( instToId, newDictBndr, newDictBndrs, newMethod, getOverlapFlag )
-import InstEnv		( mkLocalInstance )
-import TcEnv		( tcLookupLocatedClass, 
-			  tcExtendTyVarEnv, tcExtendIdEnv,
-			  InstInfo(..), pprInstInfoDetails,
-			  simpleInstInfoTyCon, simpleInstInfoTy,
-			  InstBindings(..), newDFunName
-			)
-import TcBinds		( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..), 
-			  TcSigFun, mkTcSigFun )
-import TcHsType		( tcHsKindedType, tcHsSigType )
-import TcSimplify	( tcSimplifyCheck )
-import TcUnify		( checkSigTyVars, sigCtxt )
-import TcMType		( tcSkolSigTyVars )
-import TcType		( Type, SkolemInfo(ClsSkol, InstSkol), UserTypeCtxt( GenPatCtxt ),
-			  TcType, TcThetaType, TcTyVar, mkTyVarTys,
-			  mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
-			  tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
-			  getClassPredTys_maybe, mkPhiTy, mkTyVarTy
-			)
+import RnHsSyn
+import RnExpr
+import RnEnv
+import Inst
+import InstEnv
+import TcEnv
+import TcBinds
+import TcHsType
+import TcSimplify
+import TcUnify
+import TcMType
+import TcType
 import TcRnMonad
-import Generics		( mkGenericRhs, validGenericInstanceType )
-import PrelInfo		( nO_METHOD_BINDING_ERROR_ID )
-import Class		( classTyVars, classBigSig, 
-			  Class, ClassOpItem, DefMeth (..) )
-import TyCon		( TyCon, tyConName, tyConHasGenerics )
-import Type		( substTyWith )
-import MkId		( mkDefaultMethodId, mkDictFunId )
-import Id		( Id, idType, idName, mkUserLocal )
-import Name		( Name, NamedThing(..) )
-import NameEnv		( NameEnv, lookupNameEnv, mkNameEnv )
-import NameSet		( nameSetToList )
-import OccName		( reportIfUnused, mkDefaultMethodOcc )
-import RdrName		( RdrName, mkDerivedRdrName )
+import Generics
+import PrelInfo
+import Class
+import TyCon
+import Type
+import MkId
+import Id
+import Name
+import NameEnv
+import NameSet
+import OccName
+import RdrName
 import Outputable
-import PrelNames	( genericTyConNames )
+import PrelNames
 import DynFlags
-import ErrUtils		( dumpIfSet_dyn )
-import Util		( count, lengthIs, isSingleton, lengthExceeds )
-import Unique		( Uniquable(..) )
-import ListSetOps	( equivClassesByUniq, minusList	)
-import SrcLoc		( Located(..), srcSpanStart, unLoc, noLoc )
-import Maybes		( seqMaybe, isJust, mapCatMaybes )
-import List		( partition )
-import BasicTypes	( RecFlag(..), Boxity(..) )
+import ErrUtils
+import Util
+import Unique
+import ListSetOps
+import SrcLoc
+import Maybes
+import List
+import BasicTypes
 import Bag
 import FastString
 \end{code}
 
 
-
 Dictionary handling
 ~~~~~~~~~~~~~~~~~~~
 Every class implicitly declares a new data type, corresponding to dictionaries
@@ -282,7 +271,7 @@ tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
     
         -- Check the context
 	{ dict_binds <- tcSimplifyCheck
-			        (ptext SLIT("class") <+> ppr clas)
+			        loc
 				tyvars
 			        [this_dict]
 			        insts_needed
@@ -373,18 +362,18 @@ tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
 
     let
 	[(_, Just sig, local_meth_id)] = mono_bind_infos
+	loc = sig_loc sig
     in
 
     addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))	$
-    newDictBndrs (sig_loc sig) (sig_theta sig)		`thenM` \ meth_dicts ->
+    newDictBndrs loc (sig_theta sig)		`thenM` \ meth_dicts ->
     let
 	meth_tvs   = sig_tvs sig
 	all_tyvars = meth_tvs ++ inst_tyvars
 	all_insts  = avail_insts ++ meth_dicts
     in
     tcSimplifyCheck
-	 (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
-	 all_tyvars all_insts meth_lie		`thenM` \ lie_binds ->
+	 loc all_tyvars all_insts meth_lie	`thenM` \ lie_binds ->
 
     checkSigTyVars all_tyvars			`thenM_`
 
@@ -548,8 +537,8 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
 				  other						  -> Nothing
 			other -> Nothing
 
-isInstDecl (SigOrigin (InstSkol _)) = True
-isInstDecl (SigOrigin (ClsSkol _))  = False
+isInstDecl (SigOrigin InstSkol)    = True
+isInstDecl (SigOrigin (ClsSkol _)) = False
 \end{code}
 
 
@@ -632,6 +621,8 @@ get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 	--	f {| a+b |} ... = ...
 	--	f {| x+y |} ... = ...
 	-- Then at this point we'll have an InstInfo for each
+	--
+	-- The class should be unary, which is why simpleInstInfoTyCon should be ok
     let
 	tc_inst_infos :: [(TyCon, InstInfo)]
 	tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
@@ -739,8 +730,12 @@ tcAddDeclCtxt decl thing_inside
      thing = case decl of
 	   	ClassDecl {}		  -> "class"
 		TySynonym {}		  -> "type synonym"
-		TyData {tcdND = NewType}  -> "newtype"
-		TyData {tcdND = DataType} -> "data type"
+		TyFunction {}		  -> "type function signature"
+		TyData {tcdND = NewType}  -> "newtype" ++ maybeSig
+		TyData {tcdND = DataType} -> "data type" ++ maybeSig
+
+     maybeSig | isKindSigDecl decl = " signature"
+	      | otherwise	   = ""
 
      ctxt = hsep [ptext SLIT("In the"), text thing, 
 		  ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
@@ -755,9 +750,16 @@ badMethodErr clas op
   = hsep [ptext SLIT("Class"), quotes (ppr clas), 
 	  ptext SLIT("does not have a method"), quotes (ppr op)]
 
+badATErr clas at
+  = hsep [ptext SLIT("Class"), quotes (ppr clas), 
+	  ptext SLIT("does not have an associated type"), quotes (ppr at)]
+
 omittedMethodWarn sel_id
   = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 
+omittedATWarn at
+  = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
+
 badGenericInstance sel_id because
   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 	 because]