checkTauTvUpdate: take synonym families into account

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index eee6df9..3d42498 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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