From ac5b9252d1513b32031d860bbd8a89397dc1b7b3 Mon Sep 17 00:00:00 2001
From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Fri, 29 Jun 2007 06:36:56 +0000
Subject: [PATCH] Checking that type indexes contain no synonym family
 applications

---
 compiler/typecheck/TcTyClsDecls.lhs |   53 +++++++++++++++++++++++++++++------
 1 file changed, 45 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 56ff0e1..8a07fae 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -267,8 +267,13 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
-       ; -- (3) check that the right-hand side is a tau type
-       ; unless (isTauTy t_rhs) $
+         -- (3) check that 
+         --     - left-hand side contains no type family applications
+         --       (vanilla synonyms are fine, though)
+       ; mappM_ checkTyFamFreeness t_typats
+
+         --     - the right-hand side is a tau type
+       ; unless (isTauTy t_rhs) $ 
 	   addErr (polyTyErr t_rhs)
 
          -- (4) construct representation tycon
@@ -299,17 +304,23 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
        ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
        ; unbox_strict <- doptM Opt_UnboxStrictFields
 
-	 -- Check that we don't use GADT syntax for indexed types
+         -- kind check the type indexes and the context
+       ; t_typats     <- mappM tcHsKindedType k_typats
+       ; stupid_theta <- tcHsKindedContext k_ctxt
+
+         -- (3) Check that
+         --     - left-hand side contains no type family applications
+         --       (vanilla synonyms are fine, though)
+       ; mappM_ checkTyFamFreeness t_typats
+
+	 --     - we don't use GADT syntax for indexed types
        ; checkTc h98_syntax (badGadtIdxTyDecl tc_name)
 
-	 -- Check that a newtype has exactly one constructor
+	 --     - a newtype has exactly one constructor
        ; checkTc (new_or_data == DataType || isSingleton k_cons) $
 	   newtypeConError tc_name (length k_cons)
 
-       ; t_typats     <- mappM tcHsKindedType k_typats
-       ; stupid_theta <- tcHsKindedContext k_ctxt
-
-         -- (3) construct representation tycon
+         -- (4) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name loc
        ; tycon <- fixM (\ tycon -> do 
 	     { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs))
@@ -336,6 +347,27 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 			L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
 			other -> True
 
+-- Check that a type index does not contain any type family applications
+--
+-- * Earlier phases have already checked that there are no foralls in the
+--   type; we also cannot have PredTys and NoteTys are being skipped by using
+--   the core view. 
+--
+checkTyFamFreeness :: Type -> TcM ()
+checkTyFamFreeness ty | Just (tycon, tys) <- splitTyConApp_maybe ty
+                      = if isSynTyCon tycon 
+                        then addErr $ tyFamAppInIndexErr ty
+                        else mappM_ checkTyFamFreeness tys
+                          -- splitTyConApp_maybe uses the core view; hence,
+                          -- any synonym tycon must be a family tycon
+
+                      | Just (ty1, ty2) <- splitAppTy_maybe ty
+                      = checkTyFamFreeness ty1 >> checkTyFamFreeness ty2
+
+                      | otherwise          -- only vars remaining
+                      = return ()
+
+
 -- Kind checking of indexed types
 -- -
 
@@ -1211,6 +1243,11 @@ polyTyErr ty
   = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $
       ppr ty
 
+tyFamAppInIndexErr ty
+  = hang (ptext SLIT("Illegal type family application in type instance") <> 
+         colon) 4 $
+      ppr ty
+
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
 	 nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]
-- 
1.7.10.4