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.

6 files changed, 82 insertions, 21 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 2e05270065..52162a09c8 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -2274,22 +2274,31 @@ pprStmt (ApplicativeStmt _ args mb_join)
        (if lengthAtLeast args 2 then parens else id) ap_expr
 
    pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
-   pp_arg (_, ApplicativeArgOne _ pat expr isBody _)
-     | isBody =  -- See Note [Applicative BodyStmt]
-     ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
+   pp_arg (_, applicativeArg) = ppr applicativeArg
+
+pprStmt (XStmtLR x) = ppr x
+
+
+instance (OutputableBndrId idL)
+      => Outputable (ApplicativeArg (GhcPass idL)) where
+  ppr = pprArg
+
+pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
+pprArg (ApplicativeArgOne _ pat expr isBody _)
+  | isBody =  -- See Note [Applicative BodyStmt]
+    ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
             :: ExprStmt (GhcPass idL))
-     | otherwise =
-     ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+  | otherwise =
+    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
             :: ExprStmt (GhcPass idL))
-   pp_arg (_, ApplicativeArgMany _ stmts return pat) =
+pprArg (ApplicativeArgMany _ stmts return pat) =
      ppr pat <+>
      text "<-" <+>
      ppr (HsDo (panic "pprStmt") DoExpr (noLoc
                (stmts ++
                    [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))
-   pp_arg (_, XApplicativeArg x) = ppr x
 
-pprStmt (XStmtLR x) = ppr x
+pprArg (XApplicativeArg x) = ppr x
 
 pprTransformStmt :: (OutputableBndrId p)
                  => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index eca5b42e3e..79df0331b3 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -1498,7 +1498,7 @@ ApplicativeDo touches a few phases in the compiler:
   scheduled as outlined above and transformed into applicative
   combinators.  However, the code is still represented as a do-block
   with special forms of applicative statements. This allows us to
-  recover the original do-block when e.g.  printing type errors, where
+  recover the original do-block when e.g. printing type errors, where
   we don't want to show any of the applicative combinators since they
   don't exist in the source code.
   See ApplicativeStmt and ApplicativeArg in HsExpr.
@@ -1682,7 +1682,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op
                             , is_body_stmt     = False
                             , fail_operator    = fail_op}]
                       False tail'
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
                 tail _tail_fvs
   | (False,tail') <- needJoin monad_names tail
   = mkApplicativeStmt ctxt
@@ -1691,7 +1691,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)
        , app_arg_pattern  = nlWildPatName
        , arg_expr         = rhs
        , is_body_stmt     = True
-       , fail_operator    = fail_op}] False tail'
+       , fail_operator    = noSyntaxExpr}] False tail'
 
 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
   return (s : tail, emptyNameSet)
@@ -1706,7 +1706,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
    pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
    let (stmts', fvss) = unzip pairs
    let (need_join, tail') =
-         if any hasStrictPattern trees
+     -- See Note [ApplicativeDo and refutable patterns]
+         if any hasRefutablePattern stmts'
          then (True, tail)
          else needJoin monad_names tail
 
@@ -1721,13 +1722,13 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
                , is_body_stmt     = False
                , fail_operator    = fail_op
                }, emptyFVs)
-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
      return (ApplicativeArgOne
              { xarg_app_arg_one = noExtField
              , app_arg_pattern  = nlWildPatName
              , arg_expr         = exp
              , is_body_stmt     = True
-             , fail_operator    = fail_op
+             , fail_operator    = noSyntaxExpr
              }, emptyFVs)
    stmtTreeArg ctxt tail_fvs tree = do
      let stmts = flattenStmtTree tree
@@ -1854,12 +1855,19 @@ isStrictPattern lpat =
     SplicePat{}     -> True
     _otherwise -> panic "isStrictPattern"
 
-hasStrictPattern :: ExprStmtTree -> Bool
-hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat
-hasStrictPattern (StmtTreeOne _) = False
-hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b
-hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees
+{-
+Note [ApplicativeDo and refutable patterns]
+
+Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.
+This means that sometimes an applicative block needs to be wrapped in 'join' simply because
+of a refutable pattern, in order for the types to work out.
+
+-}
 
+hasRefutablePattern :: ApplicativeArg GhcRn -> Bool
+hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat
+                                       , is_body_stmt = False}) = not (isIrrefutableHsPat pat)
+hasRefutablePattern _ = False
 
 isLetStmt :: LStmt a b -> Bool
 isLetStmt (L _ LetStmt{}) = True
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, [''])