[commit: ghc] master: Fix #14228 by marking SumPats as non-irrefutable (f4d50a0)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f4d50a0ec0d23dbcd61a014c8a773030c8fe310d/ghc

>---------------------------------------------------------------

commit f4d50a0ec0d23dbcd61a014c8a773030c8fe310d
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri Sep 15 14:34:58 2017 -0400

    Fix #14228 by marking SumPats as non-irrefutable
    
    `isIrrefutableHsPat` should always return `False` for unboxed sum
    patterns (`SumPat`s), since they always have at least one other
    corresponding pattern of the same arity (since the minimum arity for a
    `SumPat` is 2). Failure to do so causes incorrect code to be generated
    for pattern synonyms that use unboxed sums, as shown in #14228.
    
    Test Plan: make test TEST=T14228
    
    Reviewers: austin, bgamari, simonpj
    
    Reviewed By: simonpj
    
    Subscribers: simonpj, rwbarton, thomie
    
    GHC Trac Issues: #14228
    
    Differential Revision: https://phabricator.haskell.org/D3951


>---------------------------------------------------------------

f4d50a0ec0d23dbcd61a014c8a773030c8fe310d
 compiler/hsSyn/HsPat.hs                         | 27 +++++++++++++++++++++++--
 testsuite/tests/patsyn/should_run/T14228.hs     | 22 ++++++++++++++++++++
 testsuite/tests/patsyn/should_run/T14228.stdout |  4 ++++
 testsuite/tests/patsyn/should_run/all.T         |  1 +
 4 files changed, 52 insertions(+), 2 deletions(-)

diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index bcdcca2..4450868 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -146,7 +146,7 @@ data Pat p
 
   | SumPat      (LPat p)           -- Sum sub-pattern
                 ConTag             -- Alternative (one-based)
-                Arity              -- Arity
+                Arity              -- Arity (INVARIANT: ≥ 2)
                 (PostTc p [Type])  -- PlaceHolder before typechecker, filled in
                                    -- afterwards with the types of the
                                    -- alternative
@@ -613,7 +613,8 @@ isIrrefutableHsPat pat
     go1 (SigPatIn pat _)    = go pat
     go1 (SigPatOut pat _)   = go pat
     go1 (TuplePat pats _ _) = all go pats
-    go1 (SumPat pat _ _  _) = go pat
+    go1 (SumPat _ _ _ _)    = False
+                    -- See Note [Unboxed sum patterns aren't irrefutable]
     go1 (ListPat {})        = False
     go1 (PArrPat {})        = False     -- ?
 
@@ -634,6 +635,28 @@ isIrrefutableHsPat pat
     -- since we cannot know until the splice is evaluated.
     go1 (SplicePat {})      = False
 
+{- Note [Unboxed sum patterns aren't irrefutable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
+patterns. A simple example that demonstrates this is from #14228:
+
+  pattern Just' x = (# x | #)
+  pattern Nothing' = (# | () #)
+
+  foo x = case x of
+    Nothing' -> putStrLn "nothing"
+    Just'    -> putStrLn "just"
+
+In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable,
+as does not match an unboxed sum value of the same arity—namely, (# | y #)
+(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the
+minimum unboxed sum arity is 2.
+
+Failing to mark unboxed sum patterns as non-irrefutable would cause the Just'
+case in foo to be unreachable, as GHC would mistakenly believe that Nothing'
+is the only thing that could possibly be matched!
+-}
+
 hsPatNeedsParens :: Pat a -> Bool
 hsPatNeedsParens (NPlusKPat {})      = True
 hsPatNeedsParens (SplicePat {})      = False
diff --git a/testsuite/tests/patsyn/should_run/T14228.hs b/testsuite/tests/patsyn/should_run/T14228.hs
new file mode 100644
index 0000000..18cddd2
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T14228.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Main where
+
+type Maybe' t = (# t | () #)
+
+pattern Just' :: a -> Maybe' a
+pattern Just' x = (# x | #)
+
+pattern Nothing' :: Maybe' a
+pattern Nothing' = (# | () #)
+
+foo x = case x of
+  Nothing' -> putStrLn "nothing"
+  Just' _ -> putStrLn "just"
+
+main = do
+  putStrLn "Nothing'"
+  foo Nothing'
+
+  putStrLn "Just'"
+  foo (Just' "hello")
diff --git a/testsuite/tests/patsyn/should_run/T14228.stdout b/testsuite/tests/patsyn/should_run/T14228.stdout
new file mode 100644
index 0000000..a8ed424
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T14228.stdout
@@ -0,0 +1,4 @@
+Nothing'
+nothing
+Just'
+just
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
index 1498c1f..b087439 100644
--- a/testsuite/tests/patsyn/should_run/all.T
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -15,3 +15,4 @@ test('ghci', just_ghci, ghci_script, ['ghci.script'])
 test('T11985', just_ghci, ghci_script, ['T11985.script'])
 test('T11224', normal, compile_and_run, [''])
 test('T13688', normal, multimod_compile_and_run, ['T13688', '-v0'])
+test('T14228', normal, compile_and_run, [''])