X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=1e61c399c72c941bce4c353e19f222656048dcff;hp=e5eeac8685bda12451a6fce3e2d144387edff8aa;hb=afef39736dcde6f4947a6f362f9e6b3586933db4;hpb=dfcf88523ec5988fbcaa2cbf812cc5862ad621cf

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index e5eeac8..1e61c39 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -11,8 +11,8 @@ module TcTyClsDecls (
 #include "HsVersions.h"
 
 import HsSyn		( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
-			  ConDecl(..),   Sig(..), , NewOrData(..), ResType(..),
-			  tyClDeclTyVars, isSynDecl, hsConArgs,
+			  ConDecl(..),   Sig(..), NewOrData(..), ResType(..),
+			  tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs,
 			  LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
 			)
 import HsTypes          ( HsBang(..), getBangStrictness )
@@ -127,7 +127,12 @@ tcTyAndClassDecls boot_details decls
 	; traceTc (text "tcTyAndCl" <+> ppr mod)
 	; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
 	  do	{ let {	-- Calculate variances and rec-flag
-		      ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
+		      ; (syn_decls, alg_decls_pre) = partition (isSynDecl . unLoc) decls
+                      ; alg_decls = alg_decls_pre ++ 
+				    concat [tcdATs decl        -- add AT decls
+					   | declLoc <- alg_decls_pre
+					   , let decl = unLoc declLoc
+					   , isClassDecl decl] }
 
 			-- Extend the global env with the knot-tied results
 			-- for data types and classes
@@ -320,6 +325,7 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 	-- going to remove the constructor while coercing it to a lifted type.
 	-- And newtypes can't be bang'd
 
+-- !!!TODO -=chak
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
   = kcTyClDeclBody decl	$ \ tvs' ->
     do	{ is_boot <- tcIsHsBoot
@@ -434,10 +440,11 @@ tcTyClDecl1 calc_vrcs calc_isrec
 tcTyClDecl1 calc_vrcs calc_isrec 
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
 	      tcdCtxt = ctxt, tcdMeths = meths,
-	      tcdFDs = fundeps, tcdSigs = sigs} )
+	      tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
+  -- !!!TODO: process `ats`; what do we want to store in the `Class'? -=chak
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
 		let 	-- This little knot is just so we can get
@@ -630,7 +637,7 @@ checkValidTyCon tc
     get_fields con = dataConFieldLabels con `zip` repeat con
 	-- dataConFieldLabels may return the empty list, which is fine
 
-    -- XXX - autrijus - Make this far more complex to acommodate 
+    -- Note: The complicated checkOne logic below is there to accomodate
     --       for different return types.  Add res_ty to the mix,
     --       comparing them in two steps, all for good error messages.
     --       Plan: Use Unify.tcMatchTys to compare the first candidate's
@@ -704,11 +711,15 @@ checkValidClass cls
 	-- class has only one parameter.  We can't do generic
 	-- multi-parameter type classes!
 	; checkTc (unary || no_generics) (genericMultiParamErr cls)
+
+    	-- Check that the class has no associated types, unless GlaExs
+	; checkTc (gla_exts || no_ats) (badATDecl cls)
 	}
   where
     (tyvars, theta, _, op_stuff) = classBigSig cls
     unary 	= isSingleton tyvars
     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+    no_ats      = True -- !!!TODO: determine whether the class has ATs -=chak
 
     check_op gla_exts (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
@@ -820,6 +831,10 @@ newtypeFieldErr con_name n_flds
   = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), 
 	 nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]
 
+badATDecl cl_name
+  = vcat [ ptext SLIT("Illegal associated type declaration in") <+> quotes (ppr cl_name)
+	 , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow ATs")) ]
+
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
 	 nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]