X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcClassDcl.lhs;h=9d0fb13c54b82e05318fb1a0e76d991dc17a58ce;hp=31e3d5a0b2830df12b127815b675182697250353;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=1dfd77341ec56e9d61f2d78cb7ff2b9900385dac

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 31e3d5a..9d0fb13 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -7,7 +7,7 @@
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
 		    getGenericInstances, 
 		    MethodSpec, tcMethodBind, mkMethodBind, 
-		    tcAddDeclCtxt, badMethodErr
+		    tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
 		  ) where
 
 #include "HsVersions.h"
@@ -16,7 +16,7 @@ import HsSyn
 import RnHsSyn		( maybeGenericMatch, extractHsTyVars )
 import RnExpr		( rnLExpr )
 import RnEnv		( lookupTopBndrRn, lookupImportedName )
-import Inst		( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag )
+import Inst		( instToId, newDictBndr, newDictBndrs, newMethod, getOverlapFlag )
 import InstEnv		( mkLocalInstance )
 import TcEnv		( tcLookupLocatedClass, 
 			  tcExtendTyVarEnv, tcExtendIdEnv,
@@ -246,9 +246,13 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 	-- default methods.  Better to make separate AbsBinds for each
     let
 	(tyvars, _, _, op_items) = classBigSig clas
+	rigid_info  		 = ClsSkol clas
+	origin 			 = SigOrigin rigid_info
 	prag_fn			 = mkPragFun sigs
 	sig_fn			 = mkTcSigFun sigs
-	tc_dm			 = tcDefMeth clas tyvars default_binds sig_fn prag_fn
+	clas_tyvars		 = tcSkolSigTyVars rigid_info tyvars
+	tc_dm			 = tcDefMeth origin clas clas_tyvars
+					     default_binds sig_fn prag_fn
 
 	dm_sel_ids		 = [sel_id | (sel_id, DefMeth) <- op_items]
 	-- Generate code for polymorphic default methods only
@@ -261,19 +265,17 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
     mapAndUnzipM tc_dm dm_sel_ids	`thenM` \ (defm_binds, dm_ids_s) ->
     returnM (listToBag defm_binds, concat dm_ids_s)
     
-tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
+tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
   = do	{ dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
-	; let	rigid_info  = ClsSkol clas
-		clas_tyvars = tcSkolSigTyVars rigid_info tyvars
-		inst_tys    = mkTyVarTys clas_tyvars
+	; let	inst_tys    = mkTyVarTys tyvars
 		dm_ty       = idType sel_id	-- Same as dict selector!
-	        theta       = [mkClassPred clas inst_tys]
+	        cls_pred    = mkClassPred clas inst_tys
 		local_dm_id = mkDefaultMethodId dm_name dm_ty
-		origin 	    = SigOrigin rigid_info
 
 	; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
-	; [this_dict] <- newDicts origin theta
-	; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta [this_dict]
+	; loc <- getInstLoc origin
+	; this_dict <- newDictBndr loc cls_pred
+	; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
 							    sig_fn prag_fn meth_info)
     
 	; addErrCtxt (defltMethCtxt clas) $ do
@@ -281,12 +283,12 @@ tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
         -- Check the context
 	{ dict_binds <- tcSimplifyCheck
 			        (ptext SLIT("class") <+> ppr clas)
-				clas_tyvars
+				tyvars
 			        [this_dict]
 			        insts_needed
 
 	-- Simplification can do unification
-	; checkSigTyVars clas_tyvars
+	; checkSigTyVars tyvars
     
 	-- Inline pragmas 
 	-- We'll have an inline pragma on the local binding, made by tcMethodBind
@@ -297,9 +299,9 @@ tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
 	      inline_prags     = filter isInlineLSig (prag_fn sel_name)
 	; prags <- tcPrags dm_inst_id inline_prags
 
-	; let full_bind = AbsBinds  clas_tyvars
+	; let full_bind = AbsBinds  tyvars
 		    		    [instToId this_dict]
-		    		    [(clas_tyvars, local_dm_id, dm_inst_id, prags)]
+		    		    [(tyvars, local_dm_id, dm_inst_id, prags)]
 		    		    (dict_binds `unionBags` defm_bind)
 	; returnM (noLoc full_bind, [local_dm_id]) }}
 
@@ -374,7 +376,7 @@ tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
     in
 
     addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))	$
-    newDictsAtLoc (sig_loc sig) (sig_theta sig)		`thenM` \ meth_dicts ->
+    newDictBndrs (sig_loc sig) (sig_theta sig)		`thenM` \ meth_dicts ->
     let
 	meth_tvs   = sig_tvs sig
 	all_tyvars = meth_tvs ++ inst_tyvars
@@ -630,6 +632,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]
@@ -737,8 +741,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))]
@@ -753,9 +761,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]