Change the fail operator argument of BindStmt to be a Maybe

Don't use noSyntaxExpr for it. There is no good way to defensively case
on that, nor is it clear one ought to do so.

10 files changed, 66 insertions, 44 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index f9d4c559f0..3152571508 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1834,8 +1834,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
              (LPat idL)
              body
              (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
-             (SyntaxExpr idR) -- The fail operator
-             -- The fail operator is noSyntaxExpr
+             (Maybe (SyntaxExpr idR)) -- The fail operator
+             -- The fail operator is Nothing
              -- if the pattern match can't fail
              -- See Note [NoSyntaxExpr] (2)
 
@@ -2003,13 +2003,14 @@ data ApplicativeArg idL
     , is_body_stmt      :: Bool -- True <=> was a BodyStmt
                               -- False <=> was a BindStmt
                               -- See Note [Applicative BodyStmt]
-    , fail_operator     :: (SyntaxExpr idL) -- The fail operator
+    , 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.
-                         -- The fail operator is noSyntaxExpr
+                         -- It is also used for guards in MonadComprehensions.
+                         -- The fail operator is Nothing
                          -- if the pattern match can't fail
                          -- See Note [NoSyntaxExpr] (2)
     }
@@ -2252,7 +2253,7 @@ pprStmt (ApplicativeStmt _ args mb_join)
      [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
              :: ExprStmt (GhcPass idL))]
      | otherwise =
-     [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+     [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr Nothing
              :: ExprStmt (GhcPass idL))]
    flattenArg (_, ApplicativeArgMany _ stmts _ _) =
      concatMap flattenStmt stmts
@@ -2278,7 +2279,7 @@ pprArg (ApplicativeArgOne _ pat expr isBody _)
     ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
             :: ExprStmt (GhcPass idL))
   | otherwise =
-    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr Nothing
             :: ExprStmt (GhcPass idL))
 pprArg (ApplicativeArgMany _ stmts return pat) =
      ppr pat <+>
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 75d9219cbf..bc21cac318 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -321,8 +321,8 @@ mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
 mkBodyStmt body
   = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
 mkBindStmt pat body
-  = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr
-mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
+  = BindStmt noExtField pat body noSyntaxExpr Nothing
+mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr Nothing
   -- 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 3b6da2c5bb..976248ae53 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -714,7 +714,7 @@ addTickStmt _isGuard (BindStmt x pat e bind fail) = do
                 (addTickLPat pat)
                 (addTickLHsExprRHS e)
                 (addTickSyntaxExpr hpcSrcSpan bind)
-                (addTickSyntaxExpr hpcSrcSpan fail)
+                (mapM (addTickSyntaxExpr hpcSrcSpan) fail)
 addTickStmt isGuard (BodyStmt x e bind' guard') = do
         liftM3 (BodyStmt x)
                 (addTick isGuard e)
@@ -768,7 +768,7 @@ addTickApplicativeArg isGuard (op, arg) =
       <$> addTickLPat pat
       <*> addTickLHsExpr expr
       <*> pure isBody
-      <*> addTickSyntaxExpr hpcSrcSpan fail
+      <*> mapM (addTickSyntaxExpr hpcSrcSpan) fail
   addTickArg (ApplicativeArgMany x stmts ret pat) =
     (ApplicativeArgMany x)
       <$> addTickLStmts isGuard stmts
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index f349382f00..e9b59dddf3 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -950,7 +950,7 @@ dsDo stmts
                do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
                  ((pat, fail_op), dsLExpr expr)
                do_arg (ApplicativeArgMany _ stmts ret pat) =
-                 ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+                 ((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
 
            ; rhss' <- sequence rhss
 
@@ -983,7 +983,7 @@ dsDo stmts
       where
         new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
                                          mfix_app bind_op
-                                         noSyntaxExpr  -- Tuple cannot fail
+                                         Nothing  -- Tuple cannot fail
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
         tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
@@ -1009,17 +1009,26 @@ dsDo stmts
     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
 
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure pat match fail_op
-  | matchCanFail match
-  = do { dflags <- getDynFlags
-       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
-       ; extractMatchResult match fail_expr }
-  | otherwise
-  = extractMatchResult match (error "It can't fail")
+dsHandleMonadicFailure pat match m_fail_op
+  | matchCanFail match = do
+    fail_op <- case m_fail_op of
+      -- Note that (non-monadic) list comprehension, pattern guards, etc could
+      -- have fallible bindings without an explicit failure op, but this is
+      -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
+      -- breakdown of regular and special binds.
+      Nothing -> pprPanic "missing fail op" $
+        text "Pattern match:" <+> ppr pat <+>
+        text "is failable, and fail_expr was left unset"
+      Just fail_op -> pure fail_op
+    dflags <- getDynFlags
+    fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+    fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+    extractMatchResult match fail_expr
+  | otherwise =
+    extractMatchResult match (error "It can't fail")
 
 mk_fail_msg :: DynFlags -> Located e -> String
 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot
index e742ac5156..ea35371137 100644
--- a/compiler/GHC/HsToCore/Expr.hs-boot
+++ b/compiler/GHC/HsToCore/Expr.hs-boot
@@ -1,4 +1,5 @@
 module GHC.HsToCore.Expr where
+import GhcPrelude         ( Maybe )
 import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
 import GHC.HsToCore.Monad ( DsM, MatchResult )
 import GHC.Core           ( CoreExpr )
@@ -9,4 +10,4 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
 
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 3341427ef0..f0f7aaf376 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -585,7 +585,7 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
                                   mkBoxedTupleTy [t1,t2]))
                                exps_w_tys
 
-       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
+       ; dsMcBindStmt pat rhs bind_op Nothing bind_ty stmts_rest }
   where
     ds_inner :: ParStmtBlock GhcTc GhcTc -> DsM (CoreExpr, Type)
     ds_inner (ParStmtBlock _ stmts bndrs return_op)
@@ -609,7 +609,7 @@ matchTuple ids body
 dsMcBindStmt :: LPat GhcTc
              -> CoreExpr        -- ^ the desugared rhs of the bind statement
              -> SyntaxExpr GhcTc
-             -> SyntaxExpr GhcTc
+             -> Maybe (SyntaxExpr GhcTc)
              -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T
              -> [ExprLStmt GhcTc]
              -> DsM CoreExpr
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 20163e9d65..aafd9d2fe5 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -1665,7 +1665,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
        , app_arg_pattern  = nlWildPatName
        , arg_expr         = rhs
        , is_body_stmt     = True
-       , fail_operator    = noSyntaxExpr}] False tail'
+       , fail_operator    = Nothing}] False tail'
 
 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
   return (s : tail, emptyNameSet)
@@ -1702,7 +1702,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
              , app_arg_pattern  = nlWildPatName
              , arg_expr         = exp
              , is_body_stmt     = True
-             , fail_operator    = noSyntaxExpr
+             , fail_operator    = Nothing
              }, emptyFVs)
    stmtTreeArg ctxt tail_fvs tree = do
      let stmts = flattenStmtTree tree
@@ -2127,16 +2127,16 @@ badIpBinds what binds
 
 monadFailOp :: LPat GhcPs
             -> HsStmtContext GhcRn
-            -> RnM (SyntaxExpr GhcRn, FreeVars)
+            -> RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
 monadFailOp pat ctxt
   -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
   -- we should not need to fail.
-  | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)
+  | 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]
-  | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)
+  | not (isMonadFailStmtContext ctxt) = return (Nothing, emptyFVs)
 
   | otherwise = getMonadFailOp
 
@@ -2164,11 +2164,12 @@ So, in this case, we synthesize the function
 (rather than plain 'fail') for the 'fail' operation. This is done in
 'getMonadFailOp'.
 -}
-getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
+getMonadFailOp :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) -- Syntax expr fail op
 getMonadFailOp
  = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
       ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
-      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+      ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+      ; return (Just fail, fvs)
       }
   where
     reallyGetMonadFailOp rebindableSyntax overloadedStrings
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 7308a594e6..6d93b18494 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -581,7 +581,9 @@ tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) 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' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
+        ; fail_op' <- fmap join . forM fail_op $ \fail ->
+            tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
+
 
         ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
 
@@ -841,7 +843,8 @@ tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) 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' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
+        ; 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) }
 
@@ -937,16 +940,17 @@ tcMonadFailOp :: CtOrigin
               -> LPat GhcTcId
               -> SyntaxExpr GhcRn    -- The fail op
               -> TcType              -- Type of the whole do-expression
-              -> TcRn (SyntaxExpr GhcTcId)  -- Typechecked fail op
--- Get a 'fail' operator expression, to use if the pattern
--- match fails. If the pattern is irrefutatable, just return
--- noSyntaxExpr; it won't be used
+              -> TcRn (Maybe (SyntaxExpr 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
+-- isIrrefutableHsPat test is still required here for some reason I haven't
+-- yet determined.
 tcMonadFailOp orig pat fail_op res_ty
   | isIrrefutableHsPat pat
-  = return noSyntaxExpr
-
+  = return Nothing
   | otherwise
-  = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
+  = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
                              (mkCheckExpType res_ty) $ \_ -> return ())
 
 {-
@@ -1035,7 +1039,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
         do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
            ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                           return ()
-           ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty
+           ; fail_op' <- fmap join . forM fail_op $ \fail ->
+               tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
 
            ; return (ApplicativeArgOne
                       { app_arg_pattern = pat'
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 4e5f2be37d..3c92f39d04 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2197,7 +2197,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
                                        (L loc (VarPat noExtField (L loc fresh_it)))
                                        (nlHsApp ghciStep rn_expr)
                                        (mkRnSyntaxExpr bindIOName)
-                                       noSyntaxExpr
+                                       Nothing
 
               -- [; print it]
               print_it  = L loc $ BodyStmt noExtField
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index ede45e058b..8b7d982249 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1195,7 +1195,9 @@ zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
         ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
         ; new_body <- zBody env1 body
         ; (env2, new_pat) <- zonkPat env1 pat
-        ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
+        ; new_fail <- case fail_op of
+            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) }
 
@@ -1241,7 +1243,10 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
 
     zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op)
       = do { new_expr <- zonkLExpr env expr
-           ; (_, new_fail) <- zonkSyntaxExpr env fail_op
+           ; new_fail <- forM fail_op $ \old_fail ->
+              do { (_, fail') <- zonkSyntaxExpr env old_fail
+                 ; return fail'
+                 }
            ; return (ApplicativeArgOne x pat new_expr isBody new_fail) }
     zonk_arg env (ApplicativeArgMany x stmts ret pat)
       = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts