[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

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index d76fccf..190371c 100644 (file)
--- 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 (file)
--- 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