From 6d6ce268aa9ad3524cfd83a344c88431c40b1d00 Mon Sep 17 00:00:00 2001
From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Thu, 2 Oct 2008 13:45:39 +0000
Subject: [PATCH] TFs: Allow repeated variables in left-hand sides of
 instances

  MERGE TO 6.10
---
 compiler/rename/RnSource.lhs |   50 +++++++++++++++++++++++++++++++++++-------
 1 file changed, 42 insertions(+), 8 deletions(-)

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index cebc674..bf29b64 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -43,12 +43,13 @@ import OccName
 import Outputable
 import Bag
 import FastString
-import SrcLoc		( Located(..), unLoc, noLoc )
+import SrcLoc
 import DynFlags	( DynFlag(..) )
 import Maybe            ( isNothing )
 import BasicTypes       ( Boxity(..) )
 
 import ListSetOps    (findDupsEq)
+import List
 
 import Control.Monad
 \end{code}
@@ -640,8 +641,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
   | is_vanilla	          -- Normal Haskell data type decl
   = ASSERT( isNothing sig )	-- In normal H98 form, kind signature on the 
 				-- data type is syntactically illegal
-    bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
-    do	{ tycon' <- if isFamInstDecl tydecl
+    do  { tyvars <- pruneTyVars tydecl
+        ; bindTyVarsRn data_doc tyvars                  $ \ tyvars' -> do
+    	{ tycon' <- if isFamInstDecl tydecl
 		    then lookupLocatedOccRn     tycon -- may be imported family
 		    else lookupLocatedTopBndrRn tycon
 	; context' <- rnContext data_doc context
@@ -661,7 +663,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 		   (if isFamInstDecl tydecl
 		   then unitFV (unLoc tycon')	-- type instance => use
 		   else emptyFVs)) 
-        }
+        } }
 
   | otherwise	          -- GADT
   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
@@ -705,10 +707,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 			  returnM (Just ds', extractHsTyNames_s ds')
 
 -- "type" and "type instance" declarations
-rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+rnTyClDecl tydecl@(TySynonym {tcdLName = name,
 			      tcdTyPats = typatsMaybe, tcdSynRhs = ty})
-  = bindTyVarsRn syn_doc tyvars		        $ \ tyvars' ->
-    do { name' <- if isFamInstDecl tydecl
+  = do { tyvars <- pruneTyVars tydecl
+       ; bindTyVarsRn syn_doc tyvars                    $ \ tyvars' -> do
+       { name' <- if isFamInstDecl tydecl
 		  then lookupLocatedOccRn     name -- may be imported family
 		  else lookupLocatedTopBndrRn name
        ; typats' <- rnTyPats syn_doc typatsMaybe
@@ -720,7 +723,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 		   (if isFamInstDecl tydecl
 		   then unitFV (unLoc name')	-- type instance => use
 		   else emptyFVs))
-       }
+       } }
   where
     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 
@@ -799,6 +802,37 @@ badGadtStupidTheta _
 %*********************************************************
 
 \begin{code}
+-- Remove any duplicate type variables in family instances may have non-linear
+-- left-hand sides.  Complain if any, but the first occurence of a type
+-- variable has a user-supplied kind signature.
+--
+pruneTyVars :: TyClDecl RdrName -> RnM [LHsTyVarBndr RdrName]
+pruneTyVars tydecl
+  | isFamInstDecl tydecl
+  = do { let pruned_tyvars = nubBy eqLTyVar tyvars
+       ; assertNoSigsInRepeats tyvars
+       ; return pruned_tyvars
+       }
+  | otherwise 
+  = return tyvars
+  where
+    tyvars = tcdTyVars tydecl
+
+    assertNoSigsInRepeats []       = return ()
+    assertNoSigsInRepeats (tv:tvs)
+      = do { let offending_tvs = [ tv' | tv'@(L _ (KindedTyVar _ _)) <- tvs
+                                       , tv' `eqLTyVar` tv]
+           ; checkErr (null offending_tvs) $
+               illegalKindSig (head offending_tvs)
+           ; assertNoSigsInRepeats tvs
+           }
+
+    illegalKindSig tv
+      = hsep [ptext (sLit "Repeat variable occurrence may not have a"), 
+              ptext (sLit "kind signature:"), quotes (ppr tv)]
+
+    tv1 `eqLTyVar` tv2 = hsLTyVarLocName tv1 `eqLocated` hsLTyVarLocName tv2
+
 -- Although, we are processing type patterns here, all type variables will
 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 -- type declaration to which these patterns belong)
-- 
1.7.10.4