From 272fb49ecfeffe7aaa66b9b61bab12d8a858458d Mon Sep 17 00:00:00 2001
From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Wed, 10 Jan 2007 18:44:51 +0000
Subject: [PATCH] checkTauTvUpdate: take synonym families into account

---
 compiler/typecheck/TcType.lhs  |    4 ++--
 compiler/typecheck/TcUnify.lhs |   13 ++++++++++++-
 compiler/types/TyCon.lhs       |   11 +++++++++--
 3 files changed, 23 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index eee6df9..3d42498 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -560,8 +560,8 @@ isTauTy other		  = False
 isTauTyCon :: TyCon -> Bool
 -- Returns False for type synonyms whose expansion is a polytype
 isTauTyCon tc 
-  | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc))
-  | otherwise                             = True
+  | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc))
+  | otherwise           = True
 
 ---------------
 isBoxyTy :: TcType -> Bool
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index de9c341..b8cb1f4 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -1366,7 +1366,11 @@ checkTauTvUpdate orig_tv orig_ty
 	     ; case mb_tys' of
 		Just tys' -> return (TyConApp tc tys')
 				-- Retain the synonym (the common case)
-		Nothing   -> go (expectJust "checkTauTvUpdate" 
+		Nothing | isOpenTyCon tc
+			  -> notMonoArgs (TyConApp tc tys)
+				-- Synonym families must have monotype args
+			| otherwise
+			  -> go (expectJust "checkTauTvUpdate" 
 					(tcView (TyConApp tc tys)))
 				-- Try again, expanding the synonym
 	     }
@@ -1588,6 +1592,13 @@ notMonoType ty
 	      msg = ptext SLIT("Cannot match a monotype with") <+> quotes (ppr tidy_ty)
 	; failWithTcM (env1, msg) }
 
+notMonoArgs ty
+  = do	{ ty' <- zonkTcType ty
+	; env0 <- tcInitTidyEnv
+	; let (env1, tidy_ty) = tidyOpenType env0 ty'
+	      msg = ptext SLIT("Arguments of synonym family must be monotypes") <+> quotes (ppr tidy_ty)
+	; failWithTcM (env1, msg) }
+
 occurCheck tyvar ty
   = do	{ env0 <- tcInitTidyEnv
 	; ty'  <- zonkTcType ty
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 144a670..6dba52b 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -17,8 +17,8 @@ module TyCon(
 	SynTyConRhs(..),
 
 	isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
-	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon,
-	isPrimTyCon, 
+	isAlgTyCon, isDataTyCon, isNewTyCon, isClosedNewTyCon, isSynTyCon,
+	isClosedSynTyCon, isPrimTyCon, 
 	isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
 	assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
 	isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
@@ -600,6 +600,13 @@ isSynTyCon :: TyCon -> Bool
 isSynTyCon (SynTyCon {}) = True
 isSynTyCon _		 = False
 
+-- As for newtypes, it is in some contexts important to distinguish between
+-- closed synonyms and synonym families, as synonym families have no unique
+-- right hand side to which a synonym family application can expand.
+--
+isClosedSynTyCon :: TyCon -> Bool
+isClosedSynTyCon tycon = isSynTyCon tycon && not (isOpenTyCon tycon)
+
 isGadtSyntaxTyCon :: TyCon -> Bool
 isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res
 isGadtSyntaxTyCon other				       = False
-- 
1.7.10.4