From 29897cfe9c9cf1363b89f4eb177c85329a8ca1e5 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 19 Sep 2007 17:12:07 +0000
Subject: [PATCH] Fix exponential-time behaviour with type synonyms; rename
 -XPartiallyAppliedTypeSynonyms to -XLiberalTypeSynonyms

Fixes exponential behaviour present in GHC 6.6!

I renamed the flag because the old (not very old) name wasn't
describing what it does.
---
 compiler/main/DynFlags.hs      |    7 ++---
 compiler/typecheck/TcMType.lhs |   66 ++++++++++++++++++++++++++--------------
 docs/users_guide/flags.xml     |    6 ++--
 3 files changed, 49 insertions(+), 30 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 76fafb3..0000dcf 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -224,7 +224,7 @@ data DynFlag
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
    | Opt_PatternGuards
-   | Opt_PartiallyAppliedClosedTypeSynonyms
+   | Opt_LiberalTypeSynonyms
    | Opt_Rank2Types
    | Opt_RankNTypes
    | Opt_TypeOperators
@@ -1257,8 +1257,7 @@ xFlags = [
   ( "ParallelListComp",                 Opt_ParallelListComp ),
   ( "ForeignFunctionInterface",         Opt_ForeignFunctionInterface ),
   ( "UnliftedFFITypes",                 Opt_UnliftedFFITypes ),
-  ( "PartiallyAppliedClosedTypeSynonyms",
-    Opt_PartiallyAppliedClosedTypeSynonyms ),
+  ( "LiberalTypeSynonyms", 	        Opt_LiberalTypeSynonyms ),
   ( "Rank2Types",                       Opt_Rank2Types ),
   ( "RankNTypes",                       Opt_RankNTypes ),
   ( "TypeOperators",                    Opt_TypeOperators ),
@@ -1325,7 +1324,7 @@ glasgowExtsFlags = [
            , Opt_ExistentialQuantification
            , Opt_UnicodeSyntax
            , Opt_PatternGuards
-           , Opt_PartiallyAppliedClosedTypeSynonyms
+           , Opt_LiberalTypeSynonyms
            , Opt_RankNTypes
            , Opt_TypeOperators
            , Opt_RecursiveDo
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index f14cf59..dc811cb 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -1095,34 +1095,26 @@ check_tau_type rank ubx_tup (NoteTy other_note ty)
   = check_tau_type rank ubx_tup ty
 
 check_tau_type rank ubx_tup ty@(TyConApp tc tys)
-  | isSynTyCon tc	
-  = do	{ 	-- It's OK to have an *over-applied* type synonym
+  | isSynTyCon tc
+  = do	{ 	-- Check that the synonym has enough args
+		-- This applies eqaually to open and closed synonyms
+	 	-- It's OK to have an *over-applied* type synonym
 		--	data Tree a b = ...
 		--	type Foo a = Tree [a]
 		--	f :: Foo a b -> ...
-	; case tcView ty of
-	     Just ty' -> check_tau_type rank ubx_tup ty' -- Check expansion
-	     Nothing -> unless (isOpenTyCon tc           -- No expansion if open
-			        && tyConArity tc <= length tys) $
-		          failWithTc arity_msg
-
-	; ok <- doptM Opt_PartiallyAppliedClosedTypeSynonyms
-	; if ok && not (isOpenTyCon tc) then
-	-- Don't check the type arguments of *closed* synonyms.
-	-- This allows us to instantiate a synonym defn with a 
-	-- for-all type, or with a partially-applied type synonym.
-	-- 	e.g.   type T a b = a
-	--	       type S m   = m ()
-	--	       f :: S (T Int)
-	-- Here, T is partially applied, so it's illegal in H98.
-	-- But if you expand S first, then T we get just 
-	--	       f :: Int
-	-- which is fine.
-		returnM ()
-	  else
+ 	  checkTc (tyConArity tc <= length tys) arity_msg
+
+	-- See Note [Liberal type synonyms]
+	; liberal <- doptM Opt_LiberalTypeSynonyms
+	; if not liberal then
 		-- For H98, do check the type args
 		mappM_ check_arg_type tys
-	}
+
+	  else	-- In the liberal case, expand then check
+	  case tcView ty of   
+	     Just ty' -> check_tau_type rank ubx_tup ty' 
+	     Nothing -> pprPanic "check_tau_type" (ppr ty)
+    }
     
   | isUnboxedTupleTyCon tc
   = doptM Opt_UnboxedTuples `thenM` \ ub_tuples_allowed ->
@@ -1150,6 +1142,34 @@ ubxArgTyErr     ty = ptext SLIT("Illegal unboxed tuple type as function argument
 kindErr kind       = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
 \end{code}
 
+Note [Liberal type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
+doing validity checking.  This allows us to instantiate a synonym defn
+with a for-all type, or with a partially-applied type synonym.
+	e.g.   type T a b = a
+	       type S m   = m ()
+	       f :: S (T Int)
+Here, T is partially applied, so it's illegal in H98.  But if you
+expand S first, then T we get just
+	       f :: Int
+which is fine.
+
+IMPORTANT: suppose T is a type synonym.  Then we must do validity
+checking on an appliation (T ty1 ty2)
+
+	*either* before expansion (i.e. check ty1, ty2)
+	*or* after expansion (i.e. expand T ty1 ty2, and then check)
+	BUT NOT BOTH
+
+If we do both, we get exponential behaviour!!
+
+  data TIACons1 i r c = c i ::: r c
+  type TIACons2 t x = TIACons1 t (TIACons1 t x)
+  type TIACons3 t x = TIACons2 t (TIACons1 t x)
+  type TIACons4 t x = TIACons2 t (TIACons2 t x)
+  type TIACons7 t x = TIACons4 t (TIACons3 t x)
+
 
 %************************************************************************
 %*									*
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index d706f11..345d694 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -818,10 +818,10 @@
 	      <entry><option>-XNoUnliftedFFITypes</option></entry>
 	    </row>
 	    <row>
-	      <entry><option>-XPartiallyAppliedClosedTypeSynonyms</option></entry>
-	      <entry>Enable partially applied type synonyms.</entry>
+	      <entry><option>-XLiberalTypeSynonyms</option></entry>
+	      <entry>Enable <link linkend="type-synonyms">liberalised type synonyms</link>.</entry>
 	      <entry>dynamic</entry>
-	      <entry><option>-XNoPartiallyAppliedClosedTypeSynonyms</option></entry>
+	      <entry><option>-XNoLiberalTypeSynonyms</option></entry>
 	    </row>
 	    <row>
 	      <entry><option>-XNoRank2Types</option></entry>
-- 
1.7.10.4