Fix #14228 by marking SumPats as non-irrefutable
authorRyan Scott <ryan.gl.scott@gmail.com>
Fri, 15 Sep 2017 18:34:58 +0000 (14:34 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 19 Sep 2017 20:24:41 +0000 (16:24 -0400)
`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

(cherry picked from commit f4d50a0ec0d23dbcd61a014c8a773030c8fe310d)

compiler/hsSyn/HsPat.hs
testsuite/tests/patsyn/should_run/T14228.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_run/T14228.stdout [new file with mode: 0644]
testsuite/tests/patsyn/should_run/all.T

index 23dbd75..18457c0 100644 (file)
@@ -616,7 +616,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     -- ?
 
@@ -637,6 +638,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 (file)
index 0000000..18cddd2
--- /dev/null
@@ -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 (file)
index 0000000..a8ed424
--- /dev/null
@@ -0,0 +1,4 @@
+Nothing'
+nothing
+Just'
+just
index d98a1ff..84dc788 100644 (file)
@@ -14,3 +14,4 @@ test('records-run', normal, compile_and_run, [''])
 test('ghci', just_ghci, ghci_script, ['ghci.script'])
 test('T11985', just_ghci, ghci_script, ['T11985.script'])
 test('T11224', normal, compile_and_run, [''])
+test('T14228', normal, compile_and_run, [''])