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.

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)

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

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)

testsuite/tests/ado/T17835.hs

+-- 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

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)

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, [''])