From 1e25bdc2ea3683b7b9932e709ca90e258ad6c4bf Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 9 Sep 2002 12:57:48 +0000
Subject: [PATCH] [project @ 2002-09-09 12:57:47 by simonpj]
 -------------------------------- 	Fix rank-2
 pattern-match failure 	--------------------------------

This fixes the failure when you have a rank-2 type sig
matching a data type pattern.  Thus

	data T a = T1 | T2 a

	f :: (forall x. T x) -> Int
	f T1 = ...

This crashes GHC 5.04
---
 ghc/compiler/deSugar/Match.lhs |   56 ++++++++++++++++++++++++++++++++--------
 ghc/compiler/hsSyn/HsPat.lhs   |    5 +++-
 2 files changed, 49 insertions(+), 12 deletions(-)

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index d76fccf..190371c 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -29,7 +29,7 @@ import TysWiredIn	( nilDataCon, consDataCon, mkTupleTy, mkListTy,
 import BasicTypes	( Boxity(..) )
 import UniqSet
 import ErrUtils		( addWarnLocHdrLine, dontAddErrLoc )
-import Util             ( lengthExceeds, notNull )
+import Util             ( lengthExceeds, isSingleton, notNull )
 import Outputable
 \end{code}
 
@@ -351,6 +351,7 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
 	--	NPat
 	--	LitPat
 	--	NPlusKPat
+	--	SigPat
 	-- but no other
 
 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
@@ -377,16 +378,6 @@ tidy1 v (AsPat var pat) match_result
     match_result' | v == var  = match_result
 		  | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
 
-tidy1 v (SigPat pat ty fn) match_result
-  = selectMatchVar pat		`thenDs` \ v' ->
-    tidy1 v' pat match_result	`thenDs` \ (WildPat _, match_result') ->
-	-- The ice is a little thin here
-	-- We only expect a SigPat (with a non-trivial coercion) wrapping
-	-- a variable pattern. If it was a constructor or literal pattern
-	-- there would be no interesting polymorphism, and hence no coercion.
-    dsExpr (HsApp fn (HsVar v))	`thenDs` \ e ->
-    returnDs (WildPat ty, adjustMatchResult (bindNonRec v' e) match_result')
-
 tidy1 v (WildPat ty) match_result
   = returnDs (WildPat ty, match_result)
 
@@ -585,12 +576,55 @@ matchUnmixedEqns all_vars@(var:vars) eqns_info
 	-- (ToDo: sort this out later)
     matchLiterals all_vars eqns_info
 
+  | isSigPat first_pat
+  = ASSERT( isSingleton eqns_info )
+    matchSigPat all_vars (head eqns_info)
   where
     first_pat		= head column_1_pats
     column_1_pats 	= [pat		                   | EqnInfo _ _   (pat:_)  _            <- eqns_info]
     remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
 \end{code}
 
+A SigPat is a type coercion and must be handled one at at time.  We can't
+combine them unless the type of the pattern inside is identical, and we don't
+bother to check for that.  For example:
+
+	data T = T1 Int | T2 Bool
+	f :: (forall a. a -> a) -> T -> t
+	f (g::Int->Int)   (T1 i) = T1 (g i)
+	f (g::Bool->Bool) (T2 b) = T2 (g b)
+
+We desugar this as follows:
+
+	f = \ g::(forall a. a->a) t::T ->
+	    let gi = g Int
+	    in case t of { T1 i -> T1 (gi i)
+			   other ->
+	    let	gb = g Bool
+	    in case t of { T2 b -> T2 (gb b)
+			   other -> fail }}
+
+Note that we do not treat the first column of patterns as a
+column of variables, because the coerced variables (gi, gb)
+would be of different types.  So we get rather grotty code.
+But I don't think this is a common case, and if it was we could
+doubtless improve it.
+
+Meanwhile, the strategy is:
+	* treat each SigPat coercion (always non-identity coercions)
+		as a separate block
+	* deal with the stuff inside, and then wrap a binding round
+		the result to bind the new variable (gi, gb, etc)
+
+\begin{code}
+matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult
+matchSigPat (var:vars) (EqnInfo n ctx (SigPat pat ty co_fn : pats) result)
+  = selectMatchVar pat						`thenDs` \ new_var ->
+    dsExpr (HsApp co_fn (HsVar var))				`thenDs` \ rhs ->
+    match (new_var:vars) [EqnInfo n ctx (pat:pats) result]	`thenDs` \ result' ->
+    returnDs (adjustMatchResult (bindNonRec new_var rhs) result')
+\end{code}	
+
 %************************************************************************
 %*									*
 %*  matchWrapper: a convenient way to call @match@			*
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 6f0cc21..7a07008 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -10,7 +10,7 @@ module HsPat (
 
 	irrefutablePat, irrefutablePats,
 	failureFreePat, isWildPat, 
-	patsAreAllCons, isConPat, 
+	patsAreAllCons, isConPat, isSigPat,
 	patsAreAllLits,	isLitPat,
 	collectPatBinders, collectOutPatBinders, collectPatsBinders,
 	collectSigTysFromPat, collectSigTysFromPats
@@ -318,6 +318,9 @@ isConPat (RecPat _ _ _ _ _)	= True
 isConPat (DictPat ds ms)	= (length ds + length ms) > 1
 isConPat other			= False
 
+isSigPat (SigPat _ _ _) = True
+isSigPat other		= False
+
 patsAreAllLits :: [OutPat id] -> Bool
 patsAreAllLits pat_list = all isLitPat pat_list
 
-- 
1.7.10.4