X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Frename%2FRnSource.lhs;h=606139b116b62824e4ed3a05f2fb4532d9d252cb;hb=202ac08f3e2afde0620e889cc81a95b2fd0ad9e1;hp=9a92f84b59b5f8c8f364454b3987ad0d30a1ecdd;hpb=82c4d36b187955e3cedbb11cff92688747773456;p=ghc-hetmet.git

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9a92f84..606139b 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -43,7 +43,7 @@ import SrcLoc		( Located(..), unLoc, noLoc )
 import DynFlags	( DynFlag(..) )
 import Maybes		( seqMaybe )
 import Maybe            ( isNothing, isJust )
-import Monad		( liftM )
+import Monad		( liftM, when )
 import BasicTypes       ( Boxity(..) )
 \end{code}
 
@@ -111,10 +111,8 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
 	   <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
 	
 	let {
-           rn_at_decls = concat 
-			   [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ;
 	   rn_group = HsGroup { hs_valds  = rn_val_decls,
-			    	hs_tyclds = rn_tycl_decls ++ rn_at_decls,
+			    	hs_tyclds = rn_tycl_decls,
 			    	hs_instds = rn_inst_decls,
 			    	hs_fixds  = rn_fix_decls,
 			    	hs_depds  = [],
@@ -282,12 +280,11 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- The typechecker (not the renamer) checks that all 
 	-- the declarations are for the right class
     let
-	at_doc   = text "In the associated types in an instance declaration"
+	at_doc   = text "In the associated types of an instance declaration"
 	at_names = map (head . tyClDeclNames . unLoc) ats
-	(_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty)
     in
     checkDupNames at_doc at_names		`thenM_`
-    rnATDefs rdrCtxt ats			`thenM` \ (ats', at_fvs) ->
+    rnATInsts ats				`thenM` \ (ats', at_fvs) ->
 
 	-- Rename the bindings
 	-- The typechecker (not the renamer) checks that all 
@@ -333,20 +330,28 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	     --     to remove the context).
 \end{code}
 
-Renaming of the associated data definitions requires adding the instance
-context, as the rhs of an AT declaration may use ATs from classes in the
-context.
+Renaming of the associated types in instances.  
+
+* We raise an error if we encounter a kind signature in an instance.
 
 \begin{code}
-rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] 
-	  -> RnM ([LTyClDecl Name], FreeVars)
-rnATDefs ctxt atDecls = 
-  mapFvRn (wrapLocFstM addCtxtAndRename) atDecls
+rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATInsts atDecls = 
+  mapFvRn (wrapLocFstM rnATInst) atDecls
   where
-    -- The parser won't accept anything, but a data declaration
-    addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} = 
-      rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)})
-      -- The source loc is somewhat half hearted... -=chak
+    rnATInst tydecl@TyFunction {} = 
+      do
+        addErr noKindSig
+	rnTyClDecl tydecl
+    rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
+    rnATInst tydecl@TyData     {} = 
+      do
+        checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
+        rnTyClDecl tydecl
+    rnATInst _                    =
+      panic "RnSource.rnATInsts: not a type declaration"
+
+noKindSig = text "Instances cannot have kind signatures"
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
@@ -769,19 +774,24 @@ needOneIdx = text "Kind signature requires at least one type index"
 
 -- Rename associated type declarations (in classes)
 --
--- * This can be data declarations, type function signatures, and (default)
---   type function equations.
+-- * This can be kind signatures and (default) type function equations.
 --
 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
   where
     rn_at (tydecl@TyData     {}) = rnTySig tydecl lookupIdxVars
     rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
-    rn_at (tydecl@TySynonym  {}) = rnTyClDecl tydecl
+    rn_at (tydecl@TySynonym  {}) = 
+      do
+        checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+        rnTyClDecl tydecl
     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 
-    lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
-    --
+    lookupIdxVars _ tyvars cont = 
+      do { checkForDups tyvars;
+	 ; tyvars' <- mappM lookupIdxVar tyvars
+	 ; cont tyvars'
+	 }
     -- Type index variables must be class parameters, which are the only
     -- type variables in scope at this point.
     lookupIdxVar (L l tyvar) =
@@ -789,6 +799,27 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 	name' <- lookupOccRn (hsTyVarName tyvar)
 	return $ L l (replaceTyVarName tyvar name')
 
+    -- Type variable may only occur once.
+    --
+    checkForDups [] = return ()
+    checkForDups (L loc tv:ltvs) = 
+      do { setSrcSpan loc $
+	     when (hsTyVarName tv `ltvElem` ltvs) $
+	       addErr (repeatedTyVar tv)
+	 ; checkForDups ltvs
+	 }
+
+    rdrName `ltvElem` [] = False
+    rdrName `ltvElem` (L _ tv:ltvs)
+      | rdrName == hsTyVarName tv = True
+      | otherwise		  = rdrName `ltvElem` ltvs
+
+noPatterns = text "Default definition for an associated synonym cannot have"
+	     <+> text "type pattern"
+
+repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
+		   quotes (ppr tv)
+
 -- This data decl will parse OK
 --	data T = a Int
 -- treating "a" as the constructor.