[commit: ghc] master: Fix grouping for pattern synonyms (29928f2)
git at git.haskell.org
git at git.haskell.org
Tue Dec 22 13:33:52 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/29928f29d53cfc7aceb7e8ab81967f784cf06159/ghc
>---------------------------------------------------------------
commit 29928f29d53cfc7aceb7e8ab81967f784cf06159
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Dec 22 14:33:23 2015 +0100
Fix grouping for pattern synonyms
When grouping pattern synonyms in the desugarer, to find when a single
match will work for the whole group, we use `Match.sameGroup`. But this
function was declaring two pattern-synonym matches equal to often.
Result: Lint errors and broken semantics.
The fix is easy. See Note [Pattern synonym groups].
Re-do typechecking for pattern synonym signatures
Test Plan: Validate
Reviewers: austin
Subscribers: thomie, mpickering, simonpj
Differential Revision: https://phabricator.haskell.org/D1684
>---------------------------------------------------------------
29928f29d53cfc7aceb7e8ab81967f784cf06159
compiler/deSugar/Match.hs | 86 +++++++++++++++++++++++++++++------------------
1 file changed, 54 insertions(+), 32 deletions(-)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index f551fa4..b5a50e7 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -196,15 +196,15 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
match_group [] = panic "match_group"
match_group eqns@((group,_) : _)
= case group of
- PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
- PgSyn _ -> matchPatSyn vars ty (dropGroup eqns)
- PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
- PgAny -> matchVariables vars ty (dropGroup 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)
- PgView _ _ -> matchView vars ty (dropGroup eqns)
+ PgCon {} -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
+ PgSyn {} -> matchPatSyn vars ty (dropGroup eqns)
+ PgLit {} -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
+ PgAny -> matchVariables vars ty (dropGroup 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)
+ PgView {} -> matchView vars ty (dropGroup eqns)
PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
-- FIXME: we should also warn about view patterns that should be
@@ -789,7 +789,7 @@ data PatGroup
= PgAny -- Immediate match: variables, wildcards,
-- lazy patterns
| PgCon DataCon -- Constructor patterns (incl list, tuple)
- | PgSyn PatSyn
+ | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
| PgLit Literal -- Literal patterns
| PgN Literal -- Overloaded literals
| PgNpK Literal -- n+k patterns
@@ -828,7 +828,28 @@ subGroup group
-- pg_map :: Map a [EquationInfo]
-- Equations seen so far in reverse order of appearance
-{-
+{- Note [Pattern synonym groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+ f (P a) = e1
+ f (P b) = e2
+ ...
+where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
+same group? We can if P is a constructor, but /not/ if P is a pattern synonym.
+Consider (Trac #11224)
+ -- readMaybe :: Read a => String -> Maybe a
+ pattern PRead :: Read a => () => a -> String
+ pattern PRead a <- (readMaybe -> Just a)
+
+ f (PRead (x::Int)) = e1
+ f (PRead (y::Bool)) = e2
+This is all fine: we match the string by trying to read an Int; if that
+fails we try to read a Bool. But clearly we can't combine the two into a single
+match.
+
+Conclusion: we can combine when we invoke PRead /at the same type/. Hence
+in PgSyn we record the instantiaing types, and use them in sameGroup.
+
Note [Take care with pattern order]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the subGroup function we must be very careful about pattern re-ordering,
@@ -841,14 +862,15 @@ sameGroup :: PatGroup -> PatGroup -> Bool
-- Same group means that a single case expression
-- or test will suffice to match both, *and* the order
-- of testing within the group is insignificant.
-sameGroup PgAny PgAny = True
-sameGroup PgBang PgBang = True
-sameGroup (PgCon _) (PgCon _) = True -- One case expression
-sameGroup (PgSyn p1) (PgSyn p2) = p1==p2
-sameGroup (PgLit _) (PgLit _) = True -- One case expression
-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 `eqType` t2
+sameGroup PgAny PgAny = True
+sameGroup PgBang PgBang = True
+sameGroup (PgCon _) (PgCon _) = True -- One case expression
+sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
+ -- eqTypes: See Note [Pattern synonym groups]
+sameGroup (PgLit _) (PgLit _) = True -- One case expression
+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 `eqType` t2
-- CoPats are in the same goup only if the type of the
-- enclosed pattern is the same. The patterns outside the CoPat
-- always have the same type, so this boils down to saying that
@@ -956,19 +978,19 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
patGroup :: DynFlags -> Pat Id -> PatGroup
-patGroup _ (WildPat {}) = PgAny
-patGroup _ (BangPat {}) = PgBang
-patGroup _ (ConPatOut { pat_con = con }) = case unLoc con of
- RealDataCon dcon -> PgCon dcon
- PatSynCon psyn -> PgSyn psyn
-patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit)
-patGroup _ (NPat (L _ olit) mb_neg _)
- = PgN (hsOverLitKey olit (isJust mb_neg))
-patGroup _ (NPlusKPat _ (L _ olit) _ _) = PgNpK (hsOverLitKey olit False)
-patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
-patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList
-patGroup _ pat = pprPanic "patGroup" (ppr pat)
+patGroup _ (ConPatOut { pat_con = L _ con
+ , pat_arg_tys = tys })
+ | RealDataCon dcon <- con = PgCon dcon
+ | PatSynCon psyn <- con = PgSyn psyn tys
+patGroup _ (WildPat {}) = PgAny
+patGroup _ (BangPat {}) = PgBang
+patGroup _ (NPat (L _ olit) mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg))
+patGroup _ (NPlusKPat _ (L _ olit) _ _) = PgNpK (hsOverLitKey olit False)
+patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
+patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList
+patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit)
+patGroup _ pat = pprPanic "patGroup" (ppr pat)
{-
Note [Grouping overloaded literal patterns]
More information about the ghc-commits
mailing list