Use trees that grow for rebindable operators for `<-` binds

Also add more documentation.

18 files changed, 135 insertions, 118 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 3152571508..43cc74563a 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1828,16 +1828,14 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
             -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | BindStmt (XBindStmt idL idR body) -- Post typechecking,
-                                -- result type of the function passed to bind;
-                                -- that is, S in (>>=) :: Q -> (R -> S) -> T
+  | BindStmt (XBindStmt idL idR body)
+             -- ^ Post renaming has optional fail and bind / (>>=) operator.
+             -- Post typechecking, also has result type of the
+             -- function passed to bind; that is, S in (>>=)
+             -- :: Q -> (R -> S) -> T
+             -- See Note [The type of bind in Stmts]
              (LPat idL)
              body
-             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
-             (Maybe (SyntaxExpr idR)) -- The fail operator
-             -- The fail operator is Nothing
-             -- if the pattern match can't fail
-             -- See Note [NoSyntaxExpr] (2)
 
   -- | 'ApplicativeStmt' represents an applicative expression built with
   -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the
@@ -1950,8 +1948,8 @@ data RecStmtTc =
 type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField
 
 type instance XBindStmt        (GhcPass _) GhcPs b = NoExtField
-type instance XBindStmt        (GhcPass _) GhcRn b = NoExtField
-type instance XBindStmt        (GhcPass _) GhcTc b = Type
+type instance XBindStmt        (GhcPass _) GhcRn b = (SyntaxExpr GhcRn, FailOperator GhcRn)
+type instance XBindStmt        (GhcPass _) GhcTc b = (SyntaxExpr GhcTc, Type, FailOperator GhcTc)
 
 type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
 type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
@@ -1994,25 +1992,41 @@ data ParStmtBlock idL idR
 type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField
 type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
 
+-- | The fail operator
+--
+-- This is used for `.. <-` "bind statments" in do notation, including
+-- non-monadic "binds" in applicative.
+--
+-- The fail operator is 'Just expr' if it potentially fail monadically. if the
+-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete
+-- pattern exception), it is 'Nothing'.
+--
+-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of
+-- expression in the 'Just' case, and why it is so.
+--
+-- See Note [Failing pattern matches in Stmts] for which contexts for
+-- '@BindStmt@'s should use the monadic fail and which shouldn't.
+type FailOperator id = Maybe (SyntaxExpr id)
+
 -- | Applicative Argument
 data ApplicativeArg idL
   = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
     { xarg_app_arg_one  :: (XApplicativeArgOne idL)
+      -- ^ The fail operator, after renaming
+      --
+      -- The fail operator is needed if this is a BindStmt
+      -- where the pattern can fail. E.g.:
+      -- (Just a) <- stmt
+      -- The fail operator will be invoked if the pattern
+      -- match fails.
+      -- It is also used for guards in MonadComprehensions.
+      -- The fail operator is Nothing
+      -- if the pattern match can't fail
     , app_arg_pattern   :: (LPat idL) -- WildPat if it was a BodyStmt (see below)
     , arg_expr          :: (LHsExpr idL)
     , is_body_stmt      :: Bool -- True <=> was a BodyStmt
                               -- False <=> was a BindStmt
                               -- See Note [Applicative BodyStmt]
-    , fail_operator     :: Maybe (SyntaxExpr idL) -- The fail operator
-                         -- The fail operator is needed if this is a BindStmt
-                         -- where the pattern can fail. E.g.:
-                         -- (Just a) <- stmt
-                         -- The fail operator will be invoked if the pattern
-                         -- match fails.
-                         -- It is also used for guards in MonadComprehensions.
-                         -- The fail operator is Nothing
-                         -- if the pattern match can't fail
-                         -- See Note [NoSyntaxExpr] (2)
     }
   | ApplicativeArgMany     -- do { stmts; return vars }
     { xarg_app_arg_many :: (XApplicativeArgMany idL)
@@ -2022,7 +2036,10 @@ data ApplicativeArg idL
     }
   | XApplicativeArg !(XXApplicativeArg idL)
 
-type instance XApplicativeArgOne  (GhcPass _) = NoExtField
+type instance XApplicativeArgOne GhcPs = NoExtField
+type instance XApplicativeArgOne GhcRn = FailOperator GhcRn
+type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
+
 type instance XApplicativeArgMany (GhcPass _) = NoExtField
 type instance XXApplicativeArg    (GhcPass _) = NoExtCon
 
@@ -2213,7 +2230,7 @@ pprStmt (LastStmt _ expr m_dollar_stripped _)
         Just False -> text "return"
         Nothing -> empty) <+>
       ppr expr
-pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
+pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr]
 pprStmt (LetStmt _ (L _ binds))   = hsep [text "let", pprBinds binds]
 pprStmt (BodyStmt _ expr _ _)     = ppr expr
 pprStmt (ParStmt _ stmtss _ _)   = sep (punctuate (text " | ") (map ppr stmtss))
@@ -2248,13 +2265,12 @@ pprStmt (ApplicativeStmt _ args mb_join)
    flattenStmt stmt = [ppr stmt]
 
    flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
-   flattenArg (_, ApplicativeArgOne _ pat expr isBody _)
+   flattenArg (_, 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 Nothing
-             :: ExprStmt (GhcPass idL))]
+     [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]
    flattenArg (_, ApplicativeArgMany _ stmts _ _) =
      concatMap flattenStmt stmts
 
@@ -2274,13 +2290,12 @@ instance (OutputableBndrId idL)
   ppr = pprArg
 
 pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
-pprArg (ApplicativeArgOne _ pat expr isBody _)
+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 Nothing
-            :: ExprStmt (GhcPass idL))
+    ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))
 pprArg (ApplicativeArgMany _ stmts return pat) =
      ppr pat <+>
      text "<-" <+>
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index bc21cac318..2a09fe5e2f 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -69,7 +69,8 @@ module GHC.Hs.Utils(
   nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
 
   -- * Stmts
-  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
+  mkTransformStmt, mkTransformByStmt, mkBodyStmt,
+  mkPsBindStmt, mkRnBindStmt, mkTcBindStmt,
   mkLastStmt,
   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
   emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
@@ -259,10 +260,10 @@ mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR))
            -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
 mkBodyStmt :: Located (bodyR GhcPs)
            -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
-mkBindStmt :: IsPass idR => (XBindStmt (GhcPass idL) (GhcPass idR)
-                         (Located (bodyR (GhcPass idR))) ~ NoExtField)
-           => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
-           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
+mkPsBindStmt :: LPat GhcPs -> Located (bodyR GhcPs)
+             -> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))
+mkRnBindStmt :: LPat GhcRn -> Located (bodyR GhcRn)
+             -> StmtLR GhcRn GhcRn (Located (bodyR GhcRn))
 mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
              -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
 
@@ -320,9 +321,9 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s
 mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
 mkBodyStmt body
   = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
-mkBindStmt pat body
-  = BindStmt noExtField pat body noSyntaxExpr Nothing
-mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr Nothing
+mkPsBindStmt pat body = BindStmt noExtField pat body
+mkRnBindStmt pat body = BindStmt (noSyntaxExpr, Nothing) pat body
+mkTcBindStmt pat body = BindStmt (noSyntaxExpr, unitTy, Nothing) pat body
   -- don't use placeHolderTypeTc above, because that panics during zonking
 
 emptyRecStmt' :: forall idL idR body. IsPass idR
@@ -1059,7 +1060,7 @@ collectLStmtBinders = collectStmtBinders . unLoc
 collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
                    -> [IdP (GhcPass idL)]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
-collectStmtBinders (BindStmt _ pat _ _ _)  = collectPatBinders pat
+collectStmtBinders (BindStmt _ pat _)      = collectPatBinders pat
 collectStmtBinders (LetStmt _  binds)      = collectLocalBinders (unLoc binds)
 collectStmtBinders (BodyStmt {})           = []
 collectStmtBinders (LastStmt {})           = []
@@ -1349,7 +1350,7 @@ lStmtsImplicits = hs_lstmts
 
     hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
             -> [(SrcSpan, [Name])]
-    hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
+    hs_stmt (BindStmt _ pat _) = lPatImplicits pat
     hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
       where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
             do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 0371d37e31..856d48d946 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -866,7 +866,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
 -- It would be simpler and more consistent to do this using second,
 -- but that's likely to be defined in terms of first.
 
-dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
+dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
     let pat_ty = hsLPatType pat
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
     let pat_vars = mkVarSet (collectPatBinders pat)
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 976248ae53..806758313a 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -709,12 +709,12 @@ addTickStmt _isGuard (LastStmt x e noret ret) = do
                 (addTickLHsExpr e)
                 (pure noret)
                 (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt x pat e bind fail) = do
-        liftM4 (BindStmt x)
-                (addTickLPat pat)
-                (addTickLHsExprRHS e)
+addTickStmt _isGuard (BindStmt (bind, ty, fail) pat e) = do
+        liftM4 (\b f -> BindStmt (b, ty, f))
                 (addTickSyntaxExpr hpcSrcSpan bind)
                 (mapM (addTickSyntaxExpr hpcSrcSpan) fail)
+                (addTickLPat pat)
+                (addTickLHsExprRHS e)
 addTickStmt isGuard (BodyStmt x e bind' guard') = do
         liftM3 (BodyStmt x)
                 (addTick isGuard e)
@@ -763,12 +763,12 @@ addTickApplicativeArg
 addTickApplicativeArg isGuard (op, arg) =
   liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
  where
-  addTickArg (ApplicativeArgOne x pat expr isBody fail) =
-    (ApplicativeArgOne x)
-      <$> addTickLPat pat
+  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
+    ApplicativeArgOne
+      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
+      <*> addTickLPat pat
       <*> addTickLHsExpr expr
       <*> pure isBody
-      <*> mapM (addTickSyntaxExpr hpcSrcSpan) fail
   addTickArg (ApplicativeArgMany x stmts ret pat) =
     (ApplicativeArgMany x)
       <$> addTickLStmts isGuard stmts
@@ -938,12 +938,10 @@ addTickLCmdStmts' lstmts res
         binders = collectLStmtsBinders lstmts
 
 addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
-addTickCmdStmt (BindStmt x pat c bind fail) = do
-        liftM4 (BindStmt x)
+addTickCmdStmt (BindStmt x pat c) = do
+        liftM2 (BindStmt x)
                 (addTickLPat pat)
                 (addTickLHsCmd c)
-                (return bind)
-                (return fail)
 addTickCmdStmt (LastStmt x c noret ret) = do
         liftM3 (LastStmt x)
                 (addTickLHsCmd c)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index e9b59dddf3..72acc11efa 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -933,7 +933,7 @@ dsDo stmts
       = do { rest <- goL stmts
            ; dsLocalBinds binds rest }
 
-    go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
+    go _ (BindStmt (bind_op, res1_ty, fail_op) pat rhs) stmts
       = do  { body     <- goL stmts
             ; rhs'     <- dsLExpr rhs
             ; var   <- selectSimpleMatchVarL pat
@@ -947,7 +947,7 @@ dsDo stmts
              let
                (pats, rhss) = unzip (map (do_arg . snd) args)
 
-               do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
+               do_arg (ApplicativeArgOne fail_op pat expr _) =
                  ((pat, fail_op), dsLExpr expr)
                do_arg (ApplicativeArgMany _ stmts ret pat) =
                  ((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
@@ -981,9 +981,13 @@ dsDo stmts
                         , recS_ret_ty = body_ty} }) stmts
       = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
       where
-        new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
-                                         mfix_app bind_op
-                                         Nothing  -- Tuple cannot fail
+        new_bind_stmt = L loc $ BindStmt
+          ( bind_op
+          , bind_ty
+          , Nothing -- Tuple cannot fail
+          )
+          (mkBigLHsPatTupId later_pats)
+          mfix_app
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
         tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 5763fac71b..24db0f0649 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -122,7 +122,7 @@ matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
         --         so we can't desugar the bindings without the
         --         body expression in hand
 
-matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do
     let upat = unLoc pat
     match_var <- selectMatchVar upat
 
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index f0f7aaf376..6571a5e974 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -241,7 +241,7 @@ deListComp (stmt@(TransStmt {}) : quals) list = do
     (inner_list_expr, pat) <- dsTransStmt stmt
     deBindComp pat inner_list_expr quals list
 
-deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
+deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above
     core_list1 <- dsLExprNoLP list1
     deBindComp pat core_list1 quals core_list2
 
@@ -349,7 +349,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
     -- Anyway, we bind the newly grouped list via the generic binding function
     dfBindComp c_id n_id (pat, inner_list_expr) quals
 
-dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
+dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do
     -- evaluate the two lists
     core_list1 <- dsLExpr list1
 
@@ -495,7 +495,7 @@ dsMcStmt (LetStmt _ binds) stmts
        ; dsLocalBinds binds rest }
 
 --   [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
+dsMcStmt (BindStmt (bind_op, bind_ty, fail_op) pat rhs) stmts
   = do { rhs' <- dsLExpr rhs
        ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
 
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index b22ef27d85..82dc98ee8b 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -660,7 +660,7 @@ translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec
 translateGuard fam_insts guard = case guard of
   BodyStmt _   e _ _ -> translateBoolGuard e
   LetStmt  _   binds -> translateLet (unLoc binds)
-  BindStmt _ p e _ _ -> translateBind fam_insts p e
+  BindStmt _ p e     -> translateBind fam_insts p e
   LastStmt        {} -> panic "translateGuard LastStmt"
   ParStmt         {} -> panic "translateGuard ParStmt"
   TransStmt       {} -> panic "translateGuard TransStmt"
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index d047170feb..40df5ec734 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1613,7 +1613,7 @@ repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stm
 repLSts stmts = repSts (map unLoc stmts)
 
 repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
-repSts (BindStmt _ p e _ _ : ss) =
+repSts (BindStmt _ p e : ss) =
    do { e2 <- repLE e
       ; ss1 <- mkGenSyms (collectPatBinders p)
       ; addBinds ss1 $ do {
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index b72336b4fc..41610d1625 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1049,7 +1049,7 @@ instance ( a ~ GhcPass p
       LastStmt _ body _ _ ->
         [ toHie body
         ]
-      BindStmt _ pat body _ _ ->
+      BindStmt _ pat body ->
         [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
         , toHie body
         ]
@@ -1174,7 +1174,7 @@ instance ( a ~ GhcPass p
          , Data (StmtLR a a (Located (HsExpr a)))
          , Data (HsLocalBinds a)
          ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
-  toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM
+  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
     [ toHie $ PS Nothing sc NoScope pat
     , toHie expr
     ]
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index aafd9d2fe5..f9b80629c1 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -573,7 +573,7 @@ methodNamesLStmt = methodNamesStmt . unLoc
 methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
 methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd
 methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd
-methodNamesStmt (BindStmt _ _ cmd _ _)         = methodNamesLCmd cmd
+methodNamesStmt (BindStmt _ _ cmd)             = methodNamesLCmd cmd
 methodNamesStmt (RecStmt { recS_stmts = stmts }) =
   methodNamesStmts stmts `addOneFV` loopAName
 methodNamesStmt (LetStmt {})                   = emptyFVs
@@ -760,8 +760,10 @@ Many things desugar to HsStmts including monadic things like `do` and `mdo`
 statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
 exhaustive list). How we deal with pattern match failure is context-dependent.
 
- * In the case of list comprehensions and pattern guards we don't need any 'fail'
-   function; the desugarer ignores the fail function field of 'BindStmt' entirely.
+ * In the case of list comprehensions and pattern guards we don't need any
+   'fail' function; the desugarer ignores the fail function of 'BindStmt'
+   entirely. That said, it ought to be 'Nothing' for clarity.
+
  * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
    expressions) we want pattern match failure to be desugared to the appropriate
    'fail' function (either that of Monad or MonadFail, depending on whether
@@ -812,7 +814,7 @@ rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
         ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)]
                   , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 
-rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
+rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside
   = do  { (body', fv_expr) <- rnBody body
                 -- The binders do not scope over the expression
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
@@ -821,7 +823,7 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
 
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
-        ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op)
+        ; return (( [( L loc (BindStmt (bind_op, fail_op) pat' body')
                      , fv_expr )]
                   , thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
@@ -1077,11 +1079,11 @@ rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
 rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
   = return [(L loc (LastStmt noExtField body noret a), emptyFVs)]
 
-rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
+rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body))
   = do
       -- should the ctxt be MDo instead?
       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
-      return [(L loc (BindStmt noExtField pat' body a b), fv_pat)]
+      return [(L loc (BindStmt noExtField pat' body), fv_pat)]
 
 rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
   = failWith (badIpBinds (text "an mdo expression") binds)
@@ -1144,7 +1146,7 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
        ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
                  L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }
 
-rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
+rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body), fv_pat)
   = do { (body', fv_expr) <- rnBody body
        ; (bind_op, fvs1) <- lookupSyntax bindMName
 
@@ -1153,7 +1155,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
        ; let bndrs = mkNameSet (collectPatBinders pat')
              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
-                  L loc (BindStmt noExtField pat' body' bind_op fail_op))] }
+                  L loc (BindStmt (bind_op, fail_op) pat' body'))] }
 
 rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
   = failWith (badIpBinds (text "an mdo expression") binds)
@@ -1645,27 +1647,27 @@ stmtTreeToStmts
 -- In the spec, but we do it here rather than in the desugarer,
 -- because we need the typechecker to typecheck the <$> form rather than
 -- the bind form, which would give rise to a Monad constraint.
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt (_, fail_op) pat rhs), _))
                 tail _tail_fvs
   | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
   -- See Note [ApplicativeDo and strict patterns]
   = mkApplicativeStmt ctxt [ApplicativeArgOne
-                            { xarg_app_arg_one = noExtField
+                            { xarg_app_arg_one = fail_op
                             , app_arg_pattern  = pat
                             , arg_expr         = rhs
                             , is_body_stmt     = False
-                            , fail_operator    = fail_op}]
+                            }]
                       False tail'
 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
                 tail _tail_fvs
   | (False,tail') <- needJoin monad_names tail
   = mkApplicativeStmt ctxt
       [ApplicativeArgOne
-       { xarg_app_arg_one = noExtField
+       { xarg_app_arg_one = Nothing
        , app_arg_pattern  = nlWildPatName
        , arg_expr         = rhs
        , is_body_stmt     = True
-       , fail_operator    = Nothing}] False tail'
+       }] False tail'
 
 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
   return (s : tail, emptyNameSet)
@@ -1688,21 +1690,19 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
    (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
    return (stmts, unionNameSets (fvs:fvss))
  where
-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt (_, fail_op) pat exp), _))
      = return (ApplicativeArgOne
-               { xarg_app_arg_one = noExtField
+               { xarg_app_arg_one = fail_op
                , app_arg_pattern  = pat
                , arg_expr         = exp
                , is_body_stmt     = False
-               , fail_operator    = fail_op
                }, emptyFVs)
    stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
      return (ApplicativeArgOne
-             { xarg_app_arg_one = noExtField
+             { xarg_app_arg_one = Nothing
              , app_arg_pattern  = nlWildPatName
              , arg_expr         = exp
              , is_body_stmt     = True
-             , fail_operator    = Nothing
              }, emptyFVs)
    stmtTreeArg ctxt tail_fvs tree = do
      let stmts = flattenStmtTree tree
@@ -1779,7 +1779,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
             pvars = mkNameSet (collectStmtBinders (unLoc stmt))
 
     isStrictPatternBind :: ExprLStmt GhcRn -> Bool
-    isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
+    isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat
     isStrictPatternBind _ = False
 
 {-
@@ -1880,9 +1880,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
   -- strict patterns though; splitSegments expects that if we return Just
   -- then we have actually done some splitting. Otherwise it will go into
   -- an infinite loop (#14163).
-  go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
+  go lets indep bndrs ((L loc (BindStmt (bind_op, fail_op) pat body), fvs): rest)
     | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
-    = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep)
+    = go lets ((L loc (BindStmt (bind_op, fail_op) pat body), fvs) : indep)
          bndrs' rest
     where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
   -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
@@ -2134,8 +2134,8 @@ monadFailOp pat ctxt
   | isIrrefutableHsPat pat = return (Nothing, emptyFVs)
 
   -- For non-monadic contexts (e.g. guard patterns, list
-  -- comprehensions, etc.) we should not need to fail.  See Note
-  -- [Failing pattern matches in Stmts]
+  -- comprehensions, etc.) we should not need to fail, or failure is handled in
+  -- a different way. See Note [Failing pattern matches in Stmts].
   | not (isMonadFailStmtContext ctxt) = return (Nothing, emptyFVs)
 
   | otherwise = getMonadFailOp
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 54d73d9f12..d330d76827 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -832,7 +832,7 @@ gen_Ix_binds loc tycon = do
       where
         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 
-        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
+        mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c)
                                  (nlHsApp (nlHsVar range_RDR)
                                           (mkLHsVarTuple [a,b]))
 
@@ -1072,7 +1072,7 @@ gen_Read_binds get_fixity loc tycon
     data_con_str con = occNameString (getOccName con)
 
     read_arg a ty = ASSERT( not (isUnliftedType ty) )
-                    noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
+                    noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 
     -- When reading field labels we might encounter
     --      a  = 3
@@ -1081,7 +1081,7 @@ gen_Read_binds get_fixity loc tycon
     -- Note the parens!
     read_field lbl a =
         [noLoc
-          (mkBindStmt
+          (mkPsBindStmt
             (nlVarPat a)
             (nlHsApp
               read_field
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 9a30f56365..2cb5427119 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -364,7 +364,7 @@ tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
         ; thing          <- thing_inside res_ty
         ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
-tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
+tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside
   = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                             thing_inside res_ty
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 6d93b18494..cc0b82901b 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -415,7 +415,7 @@ tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
         ; thing  <- thing_inside res_ty
         ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
 
-tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
+tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
   = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs
                                    -- Stmt has a context already
         ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
@@ -449,7 +449,7 @@ tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
        ; return (LastStmt x body' noret noSyntaxExpr, thing) }
 
 -- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
         ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
@@ -568,7 +568,7 @@ tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
 --                            q   ::   a
 --
 
-tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
+tcMcStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) res_ty thing_inside
            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
   = do  { ((rhs', pat', thing, new_res_ty), bind_op')
             <- tcSyntaxOp MCompOrigin bind_op
@@ -585,7 +585,7 @@ tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
             tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
 
 
-        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+        ; return (BindStmt (bind_op', new_res_ty, fail_op') pat' rhs', thing) }
 
 -- Boolean expressions.
 --
@@ -827,7 +827,7 @@ tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
        ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
        ; return (LastStmt x body' noret noSyntaxExpr, thing) }
 
-tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
+tcDoStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) res_ty thing_inside
   = do  {       -- Deal with rebindable syntax:
                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
                 -- This level of generality is needed for using do-notation
@@ -846,7 +846,7 @@ tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
         ; fail_op' <- fmap join . forM fail_op $ \fail ->
             tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
 
-        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+        ; return (BindStmt (bind_op', new_res_ty, fail_op') pat' rhs', thing) }
 
 tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
   = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
@@ -1029,13 +1029,13 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
           -> TcM (ApplicativeArg GhcTcId)
 
     goArg body_ty (ApplicativeArgOne
-                    { app_arg_pattern = pat
-                    , arg_expr        = rhs
-                    , fail_operator   = fail_op
+                    { xarg_app_arg_one = fail_op
+                    , app_arg_pattern = pat
+                    , arg_expr = rhs
                     , ..
                     }, pat_ty, exp_ty)
       = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
-        addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $
+        addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs))   $
         do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
            ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                           return ()
@@ -1043,9 +1043,9 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
                tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
 
            ; return (ApplicativeArgOne
-                      { app_arg_pattern = pat'
+                      { xarg_app_arg_one = fail_op'
+                      , app_arg_pattern = pat'
                       , arg_expr        = rhs'
-                      , fail_operator   = fail_op'
                       , .. }
                     ) }
 
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 3c92f39d04..e435f7a1a3 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2193,11 +2193,10 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
                                (NValBinds [(NonRecursive,unitBag the_bind)] [])
 
               -- [it <- e]
-              bind_stmt = L loc $ BindStmt noExtField
+              bind_stmt = L loc $ BindStmt
+                                       (mkRnSyntaxExpr bindIOName, Nothing)
                                        (L loc (VarPat noExtField (L loc fresh_it)))
                                        (nlHsApp ghciStep rn_expr)
-                                       (mkRnSyntaxExpr bindIOName)
-                                       Nothing
 
               -- [; print it]
               print_it  = L loc $ BodyStmt noExtField
@@ -2327,8 +2326,8 @@ tcUserStmt rdr_stmt@(L loc _)
 
        ; ghciStep <- getGhciStepIO
        ; let gi_stmt
-               | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt
-                     = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2
+               | (L loc (BindStmt x pat expr)) <- rn_stmt
+                     = L loc $ BindStmt x pat (nlHsApp ghciStep expr)
                | otherwise = rn_stmt
 
        ; opt_pr_flag <- goptM Opt_PrintBindResult
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 8b7d982249..e74f7d6520 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1190,7 +1190,7 @@ zonkStmt env _ (LetStmt x (L l binds))
   = do (env1, new_binds) <- zonkLocalBinds env binds
        return (env1, LetStmt x (L l new_binds))
 
-zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
+zonkStmt env zBody (BindStmt (bind_op, bind_ty, fail_op) pat body)
   = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op
         ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
         ; new_body <- zBody env1 body
@@ -1199,7 +1199,7 @@ zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
             Nothing -> return Nothing
             Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f)
         ; return ( env2
-                 , BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
+                 , BindStmt (new_bind, new_bind_ty, new_fail) new_pat new_body) }
 
 -- Scopes: join > ops (in reverse order) > pats (in forward order)
 --              > rest of stmts
@@ -1214,14 +1214,14 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
     zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
 
     get_pat :: (SyntaxExpr GhcTcId, ApplicativeArg GhcTcId) -> LPat GhcTcId
-    get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat
+    get_pat (_, ApplicativeArgOne _ pat _ _) = pat
     get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
 
     replace_pat :: LPat GhcTcId
                 -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
                 -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-    replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op)
-      = (op, ApplicativeArgOne x pat a isBody fail_op)
+    replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
+      = (op, ApplicativeArgOne fail_op pat a isBody)
     replace_pat pat (op, ApplicativeArgMany x a b _)
       = (op, ApplicativeArgMany x a b pat)
 
@@ -1241,13 +1241,13 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
            ; return (env2, (new_op, new_arg) : new_args) }
     zonk_args_rev env [] = return (env, [])
 
-    zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op)
+    zonk_arg env (ApplicativeArgOne fail_op pat expr isBody)
       = do { new_expr <- zonkLExpr env expr
            ; new_fail <- forM fail_op $ \old_fail ->
               do { (_, fail') <- zonkSyntaxExpr env old_fail
                  ; return fail'
                  }
-           ; return (ApplicativeArgOne x pat new_expr isBody new_fail) }
+           ; return (ApplicativeArgOne new_fail pat new_expr isBody) }
     zonk_arg env (ApplicativeArgMany x stmts ret pat)
       = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
            ; new_ret           <- zonkExpr env1 ret
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 5df15f2b7c..920fb8ad0b 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1147,7 +1147,7 @@ cvtStmts = mapM cvtStmt
 
 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
-cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkPsBindStmt p' e' }
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
                             ; returnL $ LetStmt noExtField (noLoc ds') }
 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 842a912b0e..9333a22bd1 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -3292,7 +3292,7 @@ stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
 
 qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
     : bindpat '<-' exp                   { runECP_PV $3 >>= \ $3 ->
-                                           ams (sLL $1 $> $ mkBindStmt $1 $3)
+                                           ams (sLL $1 $> $ mkPsBindStmt $1 $3)
                                                [mu AnnLarrow $2] }
     | exp                                { runECP_PV $1 >>= \ $1 ->
                                            return $ sL1 $1 $ mkBodyStmt $1 }