Fix #15344: use fail when desugaring applicative-do

Applicative-do has a bug where it fails to use the monadic fail method
when desugaring patternmatches which can fail. See #15344.

This patch fixes that problem. It required more rewiring than I had expected.
Applicative-do happens mostly in the renamer; that's where decisions about
scheduling are made. This schedule is then carried through the typechecker and
into the desugarer which performs the actual translation. Fixing this bug
required sending information about the fail method from the renamer, through
the type checker and into the desugarer. Previously, the desugarer didn't
have enough information to actually desugar pattern matches correctly.

As a side effect, we also fix #16628, where GHC wouldn't catch missing
MonadFail instances with -XApplicativeDo.

8 files changed, 234 insertions, 9 deletions

diff --git a/testsuite/tests/ado/T13242a.stderr b/testsuite/tests/ado/T13242a.stderr
index f31307df50..22804add1c 100644
--- a/testsuite/tests/ado/T13242a.stderr
+++ b/testsuite/tests/ado/T13242a.stderr
@@ -11,7 +11,7 @@ T13242a.hs:10:5: error:
            _ <- return 'a'
            _ <- return 'b'
            return (x == x)
-      In an equation for ‘test’:
+    • In an equation for ‘test’:
           test
             = do A x <- undefined
                  _ <- return 'a'
@@ -32,15 +32,10 @@ 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 a stmt of a 'do' block: return (x == x)
+    • 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/T15344.hs b/testsuite/tests/ado/T15344.hs
new file mode 100644
index 0000000000..3956423ef6
--- /dev/null
+++ b/testsuite/tests/ado/T15344.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ApplicativeDo #-}
+
+f :: Maybe (Maybe Int) -> Maybe Int -> Maybe Int
+f mgs mid = do
+    _ <- mid
+    (Just moi) <- mgs
+    pure (moi + 42)
+
+main :: IO ()
+main = print (f (Just Nothing) (Just 2))
diff --git a/testsuite/tests/ado/T15344.stdout b/testsuite/tests/ado/T15344.stdout
new file mode 100644
index 0000000000..4a584e4989
--- /dev/null
+++ b/testsuite/tests/ado/T15344.stdout
@@ -0,0 +1 @@
+Nothing
diff --git a/testsuite/tests/ado/T16628.hs b/testsuite/tests/ado/T16628.hs
new file mode 100644
index 0000000000..8508c19e7f
--- /dev/null
+++ b/testsuite/tests/ado/T16628.hs
@@ -0,0 +1,14 @@
+-- Bug.hs
+{-# LANGUAGE ApplicativeDo #-}
+module Main where
+
+import Data.Functor.Identity
+
+f :: Identity () -> Identity [Int] -> Identity Int
+f i0 i1 = do
+    _ <- i0
+    [x] <- i1
+    pure (x + 42)
+
+main :: IO ()
+main = print $ f (Identity ()) (Identity [])
diff --git a/testsuite/tests/ado/T16628.stderr b/testsuite/tests/ado/T16628.stderr
new file mode 100644
index 0000000000..6ea95f1754
--- /dev/null
+++ b/testsuite/tests/ado/T16628.stderr
@@ -0,0 +1,15 @@
+
+T16628.hs:10:5:
+   No instance for (MonadFail Identity)
+        arising from a do statement
+        with the failable pattern ‘[x]’
+     In a stmt of a 'do' block: [x] <- i1
+      In the expression:
+        do _ <- i0
+           [x] <- i1
+           pure (x + 42)
+      In an equation for ‘f’:
+          f i0 i1
+            = do _ <- i0
+                 [x] <- i1
+                 pure (x + 42)
diff --git a/testsuite/tests/ado/ado001.stdout b/testsuite/tests/ado/ado001.stdout
index 365860f55e..6f56cceaa0 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/ado008.hs b/testsuite/tests/ado/ado008.hs
new file mode 100644
index 0000000000..b72930496f
--- /dev/null
+++ b/testsuite/tests/ado/ado008.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo,
+             RebindableSyntax  #-}
+{- This module is mostly a copy of ado001 but tests that all those
+   functions work when we have RebindableSyntax enabled
+-}
+module Main where
+
+import Prelude hiding (return, (>>=), pure, (<*>), fmap)
+import Text.PrettyPrint as PP
+
+(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]
+
+-- a | b
+test1 :: M ()
+test1 = do
+  x1 <- a
+  x2 <- b
+  const (return ()) (x1,x2)
+
+-- no parallelism
+test2 :: M ()
+test2 = do
+  x1 <- a
+  x2 <- const g x1
+  const (return ()) (x1,x2)
+
+-- a | (b;g) | e
+test3 :: M ()
+test3 = do
+  x1 <- a
+  x2 <- b
+  x3 <- const g x2
+  x4 <- e
+  return () `const` (x1,x2,x3,x4)
+
+-- (a ; (b | g)) | c
+-- or
+-- ((a | b); g) | c
+test4 :: M ()
+test4 = do
+  x1 <- a
+  x2 <- b
+  x3 <- const g x1
+  x4 <- c
+  return () `const` (x2,x3,x4)
+
+-- (a | b | c); (g | h)
+test5 :: M ()
+test5 = do
+  x1 <- a
+  x2 <- b
+  x3 <- c
+  x4 <- const g x1
+  x5 <- const h x3
+  return () `const` (x3,x4,x5)
+
+-- b/c in parallel, e/f in parallel
+-- a; (b | (c; (d; (e | (f; g)))))
+test6 :: M ()
+test6 = do
+  x1 <- a
+  x2 <- const b x1
+  x3 <- const c x1
+  x4 <- const d x3
+  x5 <- const e x4
+  x6 <- const f x4
+  x7 <- const g x6
+  return () `const` (x1,x2,x3,x4,x5,x6,x7)
+
+-- (a | b); (c | d)
+test7 :: M ()
+test7 = do
+  x1 <- a
+  x2 <- b
+  x3 <- const c x1
+  x4 <- const d x2
+  return () `const` (x3,x4)
+
+-- a; (b | c | d)
+--
+-- alternative (but less good):
+-- ((a;b) | c); d
+test8 :: M ()
+test8 = do
+  x1 <- a
+  x2 <- const b x1
+  x3 <- c
+  x4 <- const d x1
+  return () `const` (x2,x3,x4)
+
+-- test that Lets don't get in the way
+-- ((a | (b; c)) | d) | e
+test9 :: M ()
+test9 = do
+  x1 <- a
+  let x = doc "x"  -- this shouldn't get in the way of grouping a/b
+  x2 <- b
+  x3 <- const c x2
+  x4 <- d
+  x5 <- e
+  let y = doc "y"
+  return ()
+
+-- ((a | b) ; (c | d)) | e
+test10 :: M ()
+test10 = do
+  x1 <- a
+  x2 <- b
+  let z1 = (x1,x2)
+  x3 <- const c x1
+  let z2 = (x1,x2)
+  x4 <- const d z1
+  x5 <- e
+  return (const () (x3,x4,x5))
+
+-- (a | b)
+-- This demonstrated a bug in RnExpr.segments (#11612)
+test11 :: M ()
+test11 = do
+  x1 <- a
+  let x2 = x1
+  x3 <- b
+  let x4 = c
+      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
+ , test3
+ , test4
+ , test5
+ , test6
+ , test7
+ , test8
+ , test9
+ , test10
+ , test11
+ , test12
+ ]
+
+-- Testing code, prints out the structure of a monad/applicative expression
+
+newtype M a = M (Bool -> (Maybe Doc, a))
+
+maybeParen True d = parens d
+maybeParen _ d = d
+
+run :: M a -> IO ()
+run (M m) = print d where (Just d,_) = m False
+
+fmap f m = m >>= (return . f)
+
+join :: M (M a) -> M a
+join x =  x >>= id
+
+pure a = M $ \_ -> (Nothing, a)
+
+M f <*> M a = M $ \p ->
+  let (Just d1, f') = f True
+      (Just d2, a') = a True
+  in
+      (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')
+
+return = pure
+
+M m >>= k = M $ \p ->
+  let (d1, a) = m True
+      (d2, b) = case k a of M f -> f True
+  in
+  case (d1,d2) of
+    (Nothing,Nothing) -> (Nothing, b)
+    (Just d, Nothing) -> (Just d, b)
+    (Nothing, Just d) -> (Just d, b)
+    (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b)
+
+doc :: String -> M ()
+doc d = M $ \_ -> (Just (text d), ())
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index 866e414da8..634aae2314 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -5,6 +5,7 @@ test('ado004', normalise_version('base','ghc-prim','integer-gmp'), compile, ['']
 test('ado005', normal, compile_fail, [''])
 test('ado006', normal, compile, [''])
 test('ado007', normal, compile, [''])
+test('ado008', normal, compile, [''])
 test('T11607', normal, compile_and_run, [''])
 test('ado-optimal', normal, compile_and_run, [''])
 test('T12490', normal, compile, [''])
@@ -12,3 +13,5 @@ test('T13242', normal, compile, [''])
 test('T13242a', normal, compile_fail, [''])
 test('T13875', normal, compile_and_run, [''])
 test('T14163', normal, compile_and_run, [''])
+test('T15344', normal, compile_and_run, [''])
+test('T16628', normal, compile_fail, [''])