Fix Trac #3126: matching overloaded literals

Claus Reinke uncovered a long-standing bug in GHC, whereby we were
combining the pattern-match on overloaded literals, missing the fact
that an intervening pattern (for a different literal) might also
match.  (If someone had a very odd implementation of fromInteger!)

See Note [Grouping overloaded literal patterns] in Match.lhs

If this merges smoothly to 6.10, go for it, but it's very much
a corner case.

Thank you Claus!

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index a28eb84..100a2b5 100644 (file)
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -43,6 +43,7 @@ import SrcLoc
 import Maybes
 import Util
 import Name
+import FiniteMap
 import Outputable
 import FastString
 \end{code}
@@ -289,8 +290,7 @@ match vars@(v:_) ty eqns
          (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
 
                -- Group the equations and match each group in turn
-
-       ; let grouped = (groupEquations tidy_eqns)
+       ; let grouped = groupEquations tidy_eqns
 
          -- print the view patterns that are commoned up to help debug
        ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
@@ -305,10 +305,11 @@ match vars@(v:_) ty eqns
     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
     match_group eqns@((group,_) : _)
         = case group of
+            PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
+            PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
+
             PgAny      -> matchVariables  vars ty (dropGroup eqns)
-            PgCon _    -> matchConFamily  vars ty (subGroups eqns)
-            PgLit _    -> matchLiterals   vars ty (subGroups eqns)
-            PgN _      -> matchNPats      vars ty (subGroups eqns)
+            PgN _      -> matchNPats      vars ty (dropGroup eqns)
             PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)
             PgBang     -> matchBangs      vars ty (dropGroup eqns)
             PgCo _     -> matchCoercion   vars ty (dropGroup eqns)
@@ -772,24 +773,39 @@ groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
 -- If the result is of form [g1, g2, g3], 
 -- (a) all the (pg,eq) pairs in g1 have the same pg
 -- (b) none of the gi are empty
+-- The ordering of equations is unchanged
 groupEquations eqns
   = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
   where
     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
     (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
 
-subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]]
+subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
 -- Input is a particular group.  The result sub-groups the 
 -- equations by with particular constructor, literal etc they match.
--- The order may be swizzled, so the matching should be order-independent
-subGroups groups = map (map snd) (equivClasses cmp groups)
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+subGroup group 
+    = map reverse $ eltsFM $ foldl accumulate emptyFM group
   where
-    (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2
-    (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2
-    (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2
-    (PgN   l1) `cmp_pg` (PgN   l2) = l1 `compare` l2
-       -- These are the only cases that are every sub-grouped
+    accumulate pg_map (pg, eqn)
+      = case lookupFM pg_map pg of
+          Just eqns -> addToFM pg_map pg (eqn:eqns)
+          Nothing   -> addToFM pg_map pg [eqn]
+
+    -- pg_map :: FiniteMap a [EquationInfo]
+    -- Equations seen so far in reverse order of appearance
+\end{code}
 
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not 
+swap the Nothing and y!
+
+
+\begin{code}
 sameGroup :: PatGroup -> PatGroup -> Bool
 -- Same group means that a single case expression 
 -- or test will suffice to match both, *and* the order
@@ -798,9 +814,8 @@ sameGroup PgAny      PgAny      = True
 sameGroup PgBang     PgBang     = True
 sameGroup (PgCon _)  (PgCon _)  = True         -- One case expression
 sameGroup (PgLit _)  (PgLit _)  = True         -- One case expression
-sameGroup (PgN _)    (PgN _)    = True         -- Needs conditionals
-sameGroup (PgNpK l1) (PgNpK l2) = l1==l2       -- Order is significant
-                                               -- See Note [Order of n+k]
+sameGroup (PgN l1)   (PgN l2)   = l1==l2       -- Order is significant
+sameGroup (PgNpK l1) (PgNpK l2) = l1==l2       -- See Note [Grouping overloaded literal patterns]
 sameGroup (PgCo        t1)  (PgCo t2)  = t1 `coreEqType` t2
        -- CoPats are in the same goup only if the type of the
        -- enclosed pattern is the same. The patterns outside the CoPat
@@ -905,8 +920,8 @@ patGroup (ViewPat expr p _)               = PgView expr (hsPatType (unLoc p))
 patGroup pat = pprPanic "patGroup" (ppr pat)
 \end{code}
 
-Note [Order of n+k]
-~~~~~~~~~~~~~~~~~~~
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 WATCH OUT!  Consider
 
        f (n+1) = ...
@@ -914,9 +929,11 @@ WATCH OUT!  Consider
        f (n+1) = ...
 
 We can't group the first and third together, because the second may match 
-the same thing as the first.  Contrast
-       f 1 = ...
-       f 2 = ...
-       f 1 = ...
-where we can group the first and third.  Hence we don't regard (n+1) and
-(n+2) as part of the same group.
+the same thing as the first.  Same goes for *overloaded* literal patterns
+       f 1 True = ...
+       f 2 False = ...
+       f 1 False = ...
+If the first arg matches '1' but the second does not match 'True', we
+cannot jump to the third equation!  Because the same argument might
+match '2'!
+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 5e30f32..2da52c7 100644 (file)
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -248,14 +248,8 @@ matchLiterals [] _ _ = panic "matchLiterals []"
 %************************************************************************
 
 \begin{code}
-matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
-       -- All NPats, but perhaps for different literals
-matchNPats vars ty groups
-  = do {  match_results <- mapM (matchOneNPat vars ty) groups
-       ; return (foldr1 combineMatchResults match_results) }
-
-matchOneNPat :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
+matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchNPats (var:vars) ty (eqn1:eqns)   -- All for the same literal
   = do { let NPat lit mb_neg eq_chk = firstPat eqn1
        ; lit_expr <- dsOverLit lit
        ; neg_lit <- case mb_neg of
@@ -266,7 +260,7 @@ matchOneNPat (var:vars) ty (eqn1:eqns)      -- All for the same literal
        ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
        ; return (mkGuardedMatchResult pred_expr match_result) }
-matchOneNPat vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
+matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
 \end{code}