Prevent ApplicativeDo from applying to strict pattern matches (#13875)

Test Plan:
* New unit tests
* validate

Reviewers: dfeuer, simonpj, niteria, bgamari, austin, erikd

Reviewed By: dfeuer

Subscribers: rwbarton, thomie

GHC Trac Issues: #13875

Differential Revision: https://phabricator.haskell.org/D3681

4 files changed, 48 insertions, 0 deletions

diff --git a/testsuite/tests/ado/T13875.hs b/testsuite/tests/ado/T13875.hs
new file mode 100644
index 0000000000..df35331a4a
--- /dev/null
+++ b/testsuite/tests/ado/T13875.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE ApplicativeDo #-}
+module Main where
+
+import Control.Exception
+import Control.Monad
+import Data.Maybe
+import System.Exit
+
+test0 :: Maybe ()
+test0 = do
+  () <- Just undefined
+  () <- Just undefined
+  return ()
+
+test1 :: Maybe ()
+test1 = do
+  (_,_) <- Just undefined
+  return ()
+
+test2 :: Maybe (Int,Int)
+test2 = do
+  x <- return 1
+  () <- Just undefined
+  y <- return 2
+  return (x,y)
+
+main = do
+  b <- (print (isJust test0) >> return True)
+   `catch` \ErrorCall{} -> return False
+  when b $ die "failed0"
+  b <- (print (isJust test1) >> return True)
+   `catch` \ErrorCall{} -> return False
+  when b $ die "failed1"
+  b <- (print (isJust test2) >> return True)
+   `catch` \ErrorCall{} -> return False
+  when b $ die "failed2"
diff --git a/testsuite/tests/ado/ado001.hs b/testsuite/tests/ado/ado001.hs
index e452cdd1f3..0d466c5fd1 100644
--- a/testsuite/tests/ado/ado001.hs
+++ b/testsuite/tests/ado/ado001.hs
@@ -120,6 +120,15 @@ test11 = do
       x5 = x4
   return (const () (x1,x2,x3,x4))
 
+-- (a | (b ; c))
+-- The strict pattern match forces (b;c), but a can still be parallel (#13875)
+test12 :: M ()
+test12 = do
+  x1 <- a
+  () <- b
+  x2 <- c
+  return (const () (x1,x2))
+
 main = mapM_ run
  [ test1
  , test2
@@ -132,6 +141,7 @@ main = mapM_ run
  , test9
  , test10
  , test11
+ , test12
  ]
 
 -- Testing code, prints out the structure of a monad/applicative expression
diff --git a/testsuite/tests/ado/ado001.stdout b/testsuite/tests/ado/ado001.stdout
index f7c48ca152..365860f55e 100644
--- a/testsuite/tests/ado/ado001.stdout
+++ b/testsuite/tests/ado/ado001.stdout
@@ -9,3 +9,4 @@ a; ((b | c) | d)
 ((a | (b; c)) | d) | e
 ((a | b); (c | d)) | e
 a | b
+a | (b; c)
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index 6a1b4ec612..a738c7a6df 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -9,3 +9,4 @@ test('T11607', normal, compile_and_run, [''])
 test('ado-optimal', normal, compile_and_run, [''])
 test('T12490', normal, compile, [''])
 test('T13242', normal, compile, [''])
+test('T13875', normal, compile_and_run, [''])