Use FailOperator in more places, define a couple datatypes (XBindStmtRn and XBindStmtTc) to help clarify the meaning of XBindStmt in the renamer and typechecker

11 files changed, 97 insertions, 60 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 43cc74563a..050ba91d6b 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1948,8 +1948,19 @@ data RecStmtTc =
 type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField
 
 type instance XBindStmt        (GhcPass _) GhcPs b = NoExtField
-type instance XBindStmt        (GhcPass _) GhcRn b = (SyntaxExpr GhcRn, FailOperator GhcRn)
-type instance XBindStmt        (GhcPass _) GhcTc b = (SyntaxExpr GhcTc, Type, FailOperator GhcTc)
+type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn
+type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc
+
+data XBindStmtRn = XBindStmtRn
+  { xbsrn_bindOp :: SyntaxExpr GhcRn
+  , xbsrn_failOp :: FailOperator GhcRn
+  }
+
+data XBindStmtTc = XBindStmtTc
+  { xbstc_bindOp :: SyntaxExpr GhcTc
+  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S
+  , xbstc_failOp :: FailOperator GhcTc
+  }
 
 type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
 type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
@@ -2011,7 +2022,7 @@ type FailOperator id = Maybe (SyntaxExpr id)
 -- | Applicative Argument
 data ApplicativeArg idL
   = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
-    { xarg_app_arg_one  :: (XApplicativeArgOne idL)
+    { xarg_app_arg_one  :: XApplicativeArgOne idL
       -- ^ The fail operator, after renaming
       --
       -- The fail operator is needed if this is a BindStmt
@@ -2022,17 +2033,18 @@ data ApplicativeArg idL
       -- 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]
+    , 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]
     }
   | ApplicativeArgMany     -- do { stmts; return vars }
-    { xarg_app_arg_many :: (XApplicativeArgMany idL)
+    { xarg_app_arg_many :: XApplicativeArgMany idL
     , app_stmts         :: [ExprLStmt idL] -- stmts
-    , final_expr        :: (HsExpr idL)    -- return (v1,..,vn), or just (v1,..,vn)
-    , bv_pattern        :: (LPat idL)      -- (v1,...,vn)
+    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)
+    , bv_pattern        :: LPat idL      -- (v1,...,vn)
     }
   | XApplicativeArg !(XXApplicativeArg idL)
 
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index fd723e1408..0d67899b4c 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -334,6 +334,9 @@ deriving instance Data PendingTcSplice
 deriving instance Data SyntaxExprRn
 deriving instance Data SyntaxExprTc
 
+deriving instance Data XBindStmtRn
+deriving instance Data XBindStmtTc
+
 -- ---------------------------------------------------------------------
 -- Data derivations from GHC.Hs.Lit ------------------------------------
 
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 2a09fe5e2f..0a6c2a66a6 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -322,8 +322,8 @@ mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
 mkBodyStmt body
   = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
 mkPsBindStmt pat body = BindStmt noExtField pat body
-mkRnBindStmt pat body = BindStmt (noSyntaxExpr, Nothing) pat body
-mkTcBindStmt pat body = BindStmt (noSyntaxExpr, unitTy, Nothing) pat body
+mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body
+mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultType =unitTy, xbstc_failOp = Nothing }) pat body
   -- don't use placeHolderTypeTc above, because that panics during zonking
 
 emptyRecStmt' :: forall idL idR body. IsPass idR
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 806758313a..196c4a0cf0 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -709,10 +709,14 @@ addTickStmt _isGuard (LastStmt x e noret ret) = do
                 (addTickLHsExpr e)
                 (pure noret)
                 (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt (bind, ty, fail) pat e) = do
-        liftM4 (\b f -> BindStmt (b, ty, f))
-                (addTickSyntaxExpr hpcSrcSpan bind)
-                (mapM (addTickSyntaxExpr hpcSrcSpan) fail)
+addTickStmt _isGuard (BindStmt xbs pat e) = do
+        liftM4 (\b f -> BindStmt $ XBindStmtTc
+                    { xbstc_bindOp = b
+                    , xbstc_boundResultType = xbstc_boundResultType xbs
+                    , xbstc_failOp = f
+                    })
+                (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))
+                (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))
                 (addTickLPat pat)
                 (addTickLHsExprRHS e)
 addTickStmt isGuard (BodyStmt x e bind' guard') = do
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 72acc11efa..6dc59b978a 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -933,14 +933,14 @@ dsDo stmts
       = do { rest <- goL stmts
            ; dsLocalBinds binds rest }
 
-    go _ (BindStmt (bind_op, res1_ty, fail_op) pat rhs) stmts
+    go _ (BindStmt xbs pat rhs) stmts
       = do  { body     <- goL stmts
             ; rhs'     <- dsLExpr rhs
             ; var   <- selectSimpleMatchVarL pat
             ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
-                                      res1_ty (cantFailMatchResult body)
-            ; match_code <- dsHandleMonadicFailure pat match fail_op
-            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+                         (xbstc_boundResultType xbs) (cantFailMatchResult body)
+            ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs)
+            ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
 
     go _ (ApplicativeStmt body_ty args mb_join) stmts
       = do {
@@ -982,10 +982,11 @@ dsDo stmts
       = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
       where
         new_bind_stmt = L loc $ BindStmt
-          ( bind_op
-          , bind_ty
-          , Nothing -- Tuple cannot fail
-          )
+          XBindStmtTc
+            { xbstc_bindOp = bind_op
+            , xbstc_boundResultType = bind_ty
+            , xbstc_failOp = Nothing -- Tuple cannot fail
+            }
           (mkBigLHsPatTupId later_pats)
           mfix_app
 
@@ -1013,7 +1014,7 @@ dsDo stmts
     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
 
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
 dsHandleMonadicFailure pat match m_fail_op
diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot
index ea35371137..505b062d26 100644
--- a/compiler/GHC/HsToCore/Expr.hs-boot
+++ b/compiler/GHC/HsToCore/Expr.hs-boot
@@ -1,6 +1,5 @@
 module GHC.HsToCore.Expr where
-import GhcPrelude         ( Maybe )
-import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
+import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator )
 import GHC.HsToCore.Monad ( DsM, MatchResult )
 import GHC.Core           ( CoreExpr )
 import GHC.Hs.Extension   ( GhcTc)
@@ -10,4 +9,4 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
 
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 6571a5e974..070b42a20f 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -495,9 +495,9 @@ dsMcStmt (LetStmt _ binds) stmts
        ; dsLocalBinds binds rest }
 
 --   [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt (bind_op, bind_ty, fail_op) pat rhs) stmts
+dsMcStmt (BindStmt xbs pat rhs) stmts
   = do { rhs' <- dsLExpr rhs
-       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
+       ; dsMcBindStmt pat rhs' (xbstc_bindOp xbs) (xbstc_failOp xbs) (xbstc_boundResultType xbs) stmts }
 
 -- Apply `guard` to the `exp` expression
 --
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index f9b80629c1..acb589d35e 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -762,7 +762,8 @@ 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 of 'BindStmt'
-   entirely. That said, it ought to be 'Nothing' for clarity.
+   entirely. So, for list comprehensions, the fail function is set to '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
@@ -823,8 +824,8 @@ 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 (bind_op, fail_op) pat' body')
-                     , fv_expr )]
+        ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
+        ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )]
                   , thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
@@ -1154,8 +1155,9 @@ 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
+       ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
-                  L loc (BindStmt (bind_op, fail_op) pat' body'))] }
+                  L loc (BindStmt xbsrn pat' body'))] }
 
 rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
   = failWith (badIpBinds (text "an mdo expression") binds)
@@ -1647,12 +1649,12 @@ 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 (_, fail_op) pat rhs), _))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs 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 = fail_op
+                            { xarg_app_arg_one = xbsrn_failOp xbs
                             , app_arg_pattern  = pat
                             , arg_expr         = rhs
                             , is_body_stmt     = False
@@ -1690,9 +1692,9 @@ 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 (_, fail_op) pat exp), _))
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _))
      = return (ApplicativeArgOne
-               { xarg_app_arg_one = fail_op
+               { xarg_app_arg_one = xbsrn_failOp xbs
                , app_arg_pattern  = pat
                , arg_expr         = exp
                , is_body_stmt     = False
@@ -1880,9 +1882,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 (bind_op, fail_op) pat body), fvs): rest)
+  go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest)
     | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
-    = go lets ((L loc (BindStmt (bind_op, fail_op) pat body), fvs) : indep)
+    = go lets ((L loc (BindStmt xbs 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
@@ -2127,7 +2129,7 @@ badIpBinds what binds
 
 monadFailOp :: LPat GhcPs
             -> HsStmtContext GhcRn
-            -> RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
+            -> RnM (FailOperator GhcRn, FreeVars)
 monadFailOp pat ctxt
   -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
   -- we should not need to fail.
@@ -2164,7 +2166,7 @@ So, in this case, we synthesize the function
 (rather than plain 'fail') for the 'fail' operation. This is done in
 'getMonadFailOp'.
 -}
-getMonadFailOp :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) -- Syntax expr fail op
+getMonadFailOp :: RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
 getMonadFailOp
  = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
       ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index cc0b82901b..8fb7e7da7b 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -568,10 +568,10 @@ tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
 --                            q   ::   a
 --
 
-tcMcStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) res_ty thing_inside
+tcMcStmt ctxt (BindStmt xbsrn 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
+            <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)
                           [SynRho, SynFun SynAny SynRho] res_ty $
                \ [rhs_ty, pat_ty, new_res_ty] ->
                do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
@@ -581,11 +581,15 @@ tcMcStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) res_ty thing_inside
                   ; return (rhs', pat', thing, new_res_ty) }
 
         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
-        ; fail_op' <- fmap join . forM fail_op $ \fail ->
+        ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
             tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
 
-
-        ; return (BindStmt (bind_op', new_res_ty, fail_op') pat' rhs', thing) }
+        ; let xbstc = XBindStmtTc
+                { xbstc_bindOp = bind_op'
+                , xbstc_boundResultType = new_res_ty
+                , xbstc_failOp = fail_op'
+                }
+        ; return (BindStmt xbstc pat' rhs', thing) }
 
 -- Boolean expressions.
 --
@@ -827,14 +831,14 @@ 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 (bind_op, fail_op) pat rhs) res_ty thing_inside
+tcDoStmt ctxt (BindStmt xbsrn 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
                 -- in full generality; see #1537
 
           ((rhs', pat', new_res_ty, thing), bind_op')
-            <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
+            <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $
                 \ [rhs_ty, pat_ty, new_res_ty] ->
                 do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
                    ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
@@ -843,10 +847,14 @@ tcDoStmt ctxt (BindStmt (bind_op, fail_op) pat rhs) res_ty thing_inside
                    ; return (rhs', pat', new_res_ty, thing) }
 
         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
-        ; fail_op' <- fmap join . forM fail_op $ \fail ->
+        ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
             tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
-
-        ; return (BindStmt (bind_op', new_res_ty, fail_op') pat' rhs', thing) }
+        ; let xbstc = XBindStmtTc
+                { xbstc_bindOp = bind_op'
+                , xbstc_boundResultType = new_res_ty
+                , xbstc_failOp = fail_op'
+                }
+        ; return (BindStmt xbstc pat' rhs', thing) }
 
 tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
   = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
@@ -940,7 +948,7 @@ tcMonadFailOp :: CtOrigin
               -> LPat GhcTcId
               -> SyntaxExpr GhcRn    -- The fail op
               -> TcType              -- Type of the whole do-expression
-              -> TcRn (Maybe (SyntaxExpr GhcTcId))  -- Typechecked fail op
+              -> TcRn (FailOperator GhcTcId)  -- Typechecked fail op
 -- Get a 'fail' operator expression, to use if the pattern match fails.
 -- This won't be used in cases where we've already determined the pattern
 -- match can't fail (so the fail op is Nothing), however, it seems that the
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index e435f7a1a3..091968ed21 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2194,7 +2194,10 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
 
               -- [it <- e]
               bind_stmt = L loc $ BindStmt
-                                       (mkRnSyntaxExpr bindIOName, Nothing)
+                                       (XBindStmtRn
+                                          { xbsrn_bindOp = mkRnSyntaxExpr bindIOName
+                                          , xbsrn_failOp = Nothing
+                                          })
                                        (L loc (VarPat noExtField (L loc fresh_it)))
                                        (nlHsApp ghciStep rn_expr)
 
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index e74f7d6520..1cbb8415a3 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1190,16 +1190,21 @@ 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_op, bind_ty, fail_op) pat body)
-  = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op
-        ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+zonkStmt env zBody (BindStmt xbs pat body)
+  = do  { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs)
+        ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs)
         ; new_body <- zBody env1 body
         ; (env2, new_pat) <- zonkPat env1 pat
-        ; new_fail <- case fail_op of
+        ; new_fail <- case xbstc_failOp xbs of
             Nothing -> return Nothing
             Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f)
         ; return ( env2
-                 , BindStmt (new_bind, new_bind_ty, new_fail) new_pat new_body) }
+                 , BindStmt (XBindStmtTc
+                              { xbstc_bindOp = new_bind
+                              , xbstc_boundResultType = new_bind_ty
+                              , xbstc_failOp = new_fail
+                              })
+                            new_pat new_body) }
 
 -- Scopes: join > ops (in reverse order) > pats (in forward order)
 --              > rest of stmts