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

4 files changed, 52 insertions, 2 deletions

diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index bcdcca2677..445086867d 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 0000000000..18cddd26bc
--- /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 0000000000..a8ed424881
--- /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 1498c1f2e4..b087439537 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, [''])