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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 0934919..9065d28 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -17,7 +17,7 @@ import HsSyn		( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
 			  hsTyVarName, LHsTyVarBndr, LHsType, HsType(..),
 			  mkHsAppTy
 			)
-import HsTypes          ( HsBang(..), getBangStrictness )
+import HsTypes          ( HsBang(..), getBangStrictness, hsLTyVarNames )
 import BasicTypes	( RecFlag(..), StrictnessMark(..) )
 import HscTypes		( implicitTyThings, ModDetails )
 import BuildTyCl	( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
@@ -51,7 +51,8 @@ import TyCon		( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
 			  tyConDataCons, mkForeignTyCon, isProductTyCon,
 			  isRecursiveTyCon, isOpenTyCon,
 			  tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
-                          isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon )
+                          isNewTyCon, isDataTyCon, tyConKind, 
+			  setTyConArgPoss )
 import DataCon		( DataCon, dataConUserType, dataConName, 
 			  dataConFieldLabels, dataConTyCon, dataConAllTyVars,
 			  dataConFieldType, dataConResTys )
@@ -59,14 +60,14 @@ import Var		( TyVar, idType, idName )
 import VarSet		( elemVarSet, mkVarSet )
 import Name		( Name, getSrcLoc )
 import Outputable
-import Maybe		( isJust, fromJust, isNothing )
+import Maybe		( isJust, fromJust, isNothing, catMaybes )
 import Maybes		( expectJust )
+import Monad		( unless )
 import Unify		( tcMatchTys, tcMatchTyX )
 import Util		( zipLazy, isSingleton, notNull, sortLe )
-import List		( partition )
+import List		( partition, elemIndex )
 import SrcLoc		( Located(..), unLoc, getLoc, srcLocSpan )
 import ListSetOps	( equivClasses, minusList )
-import List		( delete )
 import Digraph		( SCC(..) )
 import DynFlags		( DynFlag( Opt_GlasgowExts, Opt_Generics, 
 					Opt_UnboxStrictFields ) )
@@ -270,8 +271,12 @@ tcIdxTyInstDecl1 :: TyClDecl Name
 		 -> TcM (Maybe InstInfo, Maybe TyThing)	-- Nothing if error
 
 tcIdxTyInstDecl1 (decl@TySynonym {})
-  = kcIdxTyPats decl $ \k_tvs k_typats resKind _ ->
-    do { -- (1) kind check the right hand side of the type equation
+  = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+    do { -- check that the family declaration is for a synonym
+	 unless (isSynTyCon family) $
+	   addErr (wrongKindOfFamily family)
+
+       ; -- (1) kind check the right hand side of the type equation
        ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
 
          -- (2) type check type equation
@@ -287,7 +292,12 @@ tcIdxTyInstDecl1 (decl@TySynonym {})
 tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 			       tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
-    do { -- (1) kind check the data declaration as usual
+    do { -- check that the family declaration is for the right kind
+	 unless (new_or_data == NewType  && isNewTyCon  family ||
+		 new_or_data == DataType && isDataTyCon family) $
+	   addErr (wrongKindOfFamily family)
+
+       ; -- (1) kind check the data declaration as usual
        ; k_decl <- kcDataDecl decl k_tvs
        ; let k_ctxt = tcdCtxt k_decl
 	     k_cons = tcdCons k_decl
@@ -309,6 +319,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
        ; t_typats     <- mappM tcHsKindedType k_typats
        ; stupid_theta <- tcHsKindedContext k_ctxt
 
+       ; index <- nextDFunIndex		   -- to generate unique names
        ; tycon <- fixM (\ tycon -> do 
 	     { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
 					      tycon t_tvs))
@@ -320,7 +331,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, t_typats))
+			     False h98_syntax (Just (family, t_typats, index))
                  -- 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
@@ -707,7 +718,7 @@ tcTyClDecl1 calc_isrec
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
   ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
-  ; let ats' = map makeTyThingAssoc . concat $ atss
+  ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats)
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
 		let 	-- This little knot is just so we can get
@@ -726,9 +737,20 @@ 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"
 
+    -- For each AT argument compute the position of the corresponding class
+    -- parameter in the class head.  This will later serve as a permutation
+    -- vector when checking the validity of instance declarations.
+    setTyThingPoss [ATyCon tycon] atTyVars = 
+      let classTyVars = hsLTyVarNames tvs
+	  poss        =   catMaybes 
+			. map (`elemIndex` classTyVars) 
+			. hsLTyVarNames 
+			$ atTyVars
+		     -- There will be no Nothing, as we already passed renaming
+      in 
+      ATyCon (setTyConArgPoss tycon poss)
+    setTyThingPoss _		  _ = panic "TcTyClsDecls.setTyThingPoss"
 
 tcTyClDecl1 calc_isrec 
   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
@@ -1155,7 +1177,16 @@ tooFewParmsErr tc_name
   = ptext SLIT("Indexed type instance has too few parameters:") <+> 
     quotes (ppr tc_name)
 
-badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file")
+badBootTyIdxDeclErr = 
+  ptext SLIT("Illegal indexed type instance in hs-boot file")
+
+wrongKindOfFamily family =
+  ptext SLIT("Wrong category of type instance; declaration was for a") <+>
+  kindOfFamily
+  where
+    kindOfFamily | isSynTyCon  family = ptext SLIT("type synonym")
+		 | isDataTyCon family = ptext SLIT("data type")
+		 | isNewTyCon  family = ptext SLIT("newtype")
 
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),