X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=09349197cf5d7e2412bd482055094c3e77a5ecd4;hb=feb584b7ffd49827ff2b6e716965cfdcd344570e;hp=c0c1f59dc5de5b55fee7e25ff2293fe673d0de89;hpb=0e3e28621c97991cd89cf633c8780469f1e3b4ad;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c0c1f59..0934919 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -51,7 +51,7 @@ import TyCon		( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
 			  tyConDataCons, mkForeignTyCon, isProductTyCon,
 			  isRecursiveTyCon, isOpenTyCon,
 			  tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
-                          isNewTyCon, tyConKind )
+                          isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon )
 import DataCon		( DataCon, dataConUserType, dataConName, 
 			  dataConFieldLabels, dataConTyCon, dataConAllTyVars,
 			  dataConFieldType, dataConResTys )
@@ -311,7 +311,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 
        ; tycon <- fixM (\ tycon -> do 
 	     { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
-					      tycon t_tvs (Just t_typats)))
+					      tycon t_tvs))
 				  k_cons
 	     ; tc_rhs <-
 		 case new_or_data of
@@ -320,7 +320,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 			    ASSERT( isSingleton data_cons )
 			    mkNewTyConRhs tc_name tycon (head data_cons)
 	     ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
-			     False h98_syntax (Just family)
+			     False h98_syntax (Just (family, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
@@ -329,7 +329,6 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 	     })
 
          -- construct result
-	 -- !!!TODO: missing eq axiom
        ; return (Nothing, Just (ATyCon tycon))
        }}
        where
@@ -615,20 +614,22 @@ tcTyClDecl calc_isrec decl
 tcTyClDecl1 _calc_isrec 
   (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { gla_exts <- doptM Opt_GlasgowExts
+  { traceTc (text "type family: " <+> ppr tc_name) 
+  ; gla_exts <- doptM Opt_GlasgowExts
 
 	-- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc gla_exts $ badSigTyDecl tc_name
 
-  ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))]
+  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
   }
 
   -- kind signature for an indexed data type
 tcTyClDecl1 _calc_isrec 
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
-	   tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []})
+	   tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { extra_tvs <- tcDataKindSig mb_ksig
+  { traceTc (text "data/newtype family: " <+> ppr tc_name) 
+  ; extra_tvs <- tcDataKindSig (Just ksig)
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
   ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
@@ -677,7 +678,7 @@ tcTyClDecl1 calc_isrec
 
   ; tycon <- fixM (\ tycon -> do 
 	{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
-						 tycon final_tvs Nothing)) 
+						 tycon final_tvs)) 
 			     cons
 	; tc_rhs <-
 	    if null cons && is_boot 	-- In a hs-boot file, empty cons means
@@ -706,7 +707,7 @@ tcTyClDecl1 calc_isrec
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
   ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
-  ; let ats' = concat atss
+  ; let ats' = map makeTyThingAssoc . concat $ atss
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
 		let 	-- This little knot is just so we can get
@@ -725,6 +726,8 @@ tcTyClDecl1 calc_isrec
     tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
 				; tvs2' <- mappM tcLookupTyVar tvs2 ;
 				; return (tvs1', tvs2') }
+    makeTyThingAssoc (ATyCon tycon) = ATyCon (makeTyConAssoc tycon)
+    makeTyThingAssoc _		    = panic "makeTyThingAssoc"
 
 
 tcTyClDecl1 calc_isrec 
@@ -735,11 +738,10 @@ tcTyClDecl1 calc_isrec
 tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
 	  -> NewOrData 
 	  -> TyCon -> [TyVar] 
-	  -> Maybe [Type]       -- Just ts <=> type patterns of instance type
 	  -> ConDecl Name 
 	  -> TcM DataCon
 
-tcConDecl unbox_strict NewType tycon tc_tvs mb_typats	-- Newtypes
+tcConDecl unbox_strict NewType tycon tc_tvs	-- Newtypes
 	  (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
   = do	{ let tc_datacon field_lbls arg_ty
 		= do { arg_ty' <- tcHsKindedType arg_ty	-- No bang on newtype
@@ -749,8 +751,7 @@ tcConDecl unbox_strict NewType tycon tc_tvs mb_typats	-- Newtypes
 			   	    tc_tvs []  -- No existentials
 				    [] []      -- No equalities, predicates
 				    [arg_ty']
-				    tycon 
-				    mb_typats}
+				    tycon }
 
 		-- Check that a newtype has no existential stuff
 	; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
@@ -763,7 +764,7 @@ tcConDecl unbox_strict NewType tycon tc_tvs mb_typats	-- Newtypes
 			-- Check that the constructor has exactly one field
 	}
 
-tcConDecl unbox_strict DataType tycon tc_tvs mb_typats	-- Data types
+tcConDecl unbox_strict DataType tycon tc_tvs	-- Data types
 	  (ConDecl name _ tvs ctxt details res_ty)
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
@@ -776,8 +777,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs mb_typats	-- Data types
     		    (argStrictness unbox_strict tycon bangs arg_tys)
     		    (map unLoc field_lbls)
     		    univ_tvs ex_tvs eq_preds ctxt' arg_tys
-		    data_tc 
-		    mb_typats}
+		    data_tc }
 		-- NB:	we put data_tc, the type constructor gotten from the
 		--	constructor type signature into the data constructor;
 		--	that way checkValidDataCon can complain if it's wrong.