#11224: Program doesn't preserve semantics after pattern synonym inlining. -------------------------------------+------------------------------------- Reporter: anton.dubovik | Owner: Type: bug | Status: closed Priority: highest | Milestone: 8.0.1 Component: Compiler | Version: 7.10.2 Resolution: fixed | Keywords: | PatternSynonyms Operating System: Windows | Architecture: x86_64 | (amd64) Type of failure: Incorrect result | Test Case: at runtime | patsyn/should_run/T11224 Blocked By: | Blocking: Related Tickets: #11225 | Differential Rev(s): Phab:D1632 Wiki Page: | -------------------------------------+------------------------------------- Comment (by simonpj): This commit is the one that fixes the original (semantic) problem {{{ 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] }}} -- Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/11224#comment:29 GHC http://www.haskell.org/ghc/ The Glasgow Haskell Compiler