Fix ApplicativeDo regression #17835

A previous fix for #15344 made sure that monadic 'fail' is used properly
when translating ApplicativeDo. However, it didn't properly account
for when a 'fail' will be inserted which resulted in some programs
failing with a type error.

4 files changed, 46 insertions, 2 deletions

diff --git a/testsuite/tests/ado/T13242a.stderr b/testsuite/tests/ado/T13242a.stderr
index 22804add1c..039830e63a 100644
--- a/testsuite/tests/ado/T13242a.stderr
+++ b/testsuite/tests/ado/T13242a.stderr
@@ -32,10 +32,15 @@ T13242a.hs:13:11: error:
         ...plus 21 others
         ...plus six instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
-    • In the first argument of ‘return’, namely ‘(x == x)’
       In a stmt of a 'do' block: return (x == x)
       In the expression:
         do A x <- undefined
            _ <- return 'a'
            _ <- return 'b'
            return (x == x)
+      In an equation for ‘test’:
+          test
+            = do A x <- undefined
+                 _ <- return 'a'
+                 _ <- return 'b'
+                 return (x == x)
diff --git a/testsuite/tests/ado/T17835.hs b/testsuite/tests/ado/T17835.hs
new file mode 100644
index 0000000000..20dffebde7
--- /dev/null
+++ b/testsuite/tests/ado/T17835.hs
@@ -0,0 +1,38 @@
+-- Build.hs
+{-# LANGUAGE ApplicativeDo #-}
+module Build (configRules) where
+
+type Action = IO
+type Rules = IO
+
+type Config = ()
+
+(%>) :: String -> (String -> Action ()) -> Rules ()
+(%>) = undefined
+
+command_ :: [String] -> String -> [String] -> Action ()
+command_ = undefined
+
+recursive :: Config -> String -> [String] -> IO (FilePath, [String])
+recursive = undefined
+
+liftIO :: IO a -> Action a
+liftIO = id
+
+need :: [String] -> Action ()
+need = undefined
+
+historyDisable :: Action ()
+historyDisable = undefined
+
+get_config :: () -> Action Config
+get_config = undefined
+
+configRules :: Rules ()
+configRules = do
+  "snapshot" %> \out -> do
+    historyDisable -- 8.10-rc1 refuses to compile without bind here
+    config <- get_config ()
+    need []
+    (exe,args) <- liftIO $ recursive config "snapshot" []
+    command_ [] exe args
diff --git a/testsuite/tests/ado/ado001.stdout b/testsuite/tests/ado/ado001.stdout
index 6f56cceaa0..365860f55e 100644
--- a/testsuite/tests/ado/ado001.stdout
+++ b/testsuite/tests/ado/ado001.stdout
@@ -9,4 +9,4 @@ a; ((b | c) | d)
 ((a | (b; c)) | d) | e
 ((a | b); (c | d)) | e
 a | b
-(a | (b; c))
+a | (b; c)
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index b6f2480189..f564f365eb 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -17,3 +17,4 @@ test('T13875', normal, compile_and_run, [''])
 test('T14163', normal, compile_and_run, [''])
 test('T15344', normal, compile_and_run, [''])
 test('T16628', normal, compile_fail, [''])
+test('T17835', normal, compile, [''])