MonadFail proposal, phase 1

This implements phase 1 of the MonadFail proposal (MFP, #10751).

- MonadFail warnings are all issued as desired, tunable with two new flags
- GHC was *not* made warning-free with `-fwarn-missing-monadfail-warnings`
  (but it's disabled by default right now)

Credits/thanks to
- Franz Thoma, whose help was crucial to implementing this
- My employer TNG Technology Consulting GmbH for partially funding us
  for this work

Reviewers: goldfire, austin, #core_libraries_committee, hvr, bgamari, fmthoma

Reviewed By: hvr, bgamari, fmthoma

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1248

GHC Trac Issues: #10751

35 files changed, 765 insertions, 66 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index da08c21fca..00a7fd0b19 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -64,6 +64,9 @@ import Demand ( splitStrictSig, isBotRes )
 import HscTypes
 import DynFlags
 import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
 import MonadUtils
 import Data.Maybe
 import Pair
@@ -1503,6 +1506,11 @@ instance Monad LintM where
                            Just r -> unLintM (k r) env errs'
                            Nothing -> (Nothing, errs'))
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail LintM where
+    fail err = failWithL (text err)
+#endif
+
 instance HasDynFlags LintM where
   getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
 
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 8a733adec4..09717b768a 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1336,7 +1336,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
   -- For details on above see note [Api annotations] in ApiAnnotation
   | BindStmt (LPat idL)
              body
-             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
+             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
              (SyntaxExpr idR) -- The fail operator
              -- The fail operator is noSyntaxExpr
              -- if the pattern match can't fail
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5f63b1048e..45fb72e06d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -505,6 +505,7 @@ data WarningFlag =
    | Opt_WarnWarningsDeprecations
    | Opt_WarnDeprecatedFlags
    | Opt_WarnAMP
+   | Opt_WarnMissingMonadFailInstance
    | Opt_WarnDodgyExports
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
@@ -656,6 +657,7 @@ data ExtensionFlag
    | Opt_StaticPointers
    | Opt_Strict
    | Opt_StrictData
+   | Opt_MonadFailDesugaring
    deriving (Eq, Enum, Show)
 
 type SigOf = Map ModuleName Module
@@ -2898,6 +2900,7 @@ fWarningFlags = [
   flagSpec "warn-missing-import-lists"        Opt_WarnMissingImportList,
   flagSpec "warn-missing-local-sigs"          Opt_WarnMissingLocalSigs,
   flagSpec "warn-missing-methods"             Opt_WarnMissingMethods,
+  flagSpec "warn-missing-monadfail-instance"  Opt_WarnMissingMonadFailInstance,
   flagSpec "warn-missing-signatures"          Opt_WarnMissingSigs,
   flagSpec "warn-missing-exported-sigs"       Opt_WarnMissingExportedSigs,
   flagSpec "warn-monomorphism-restriction"    Opt_WarnMonomorphism,
@@ -3168,6 +3171,7 @@ xFlags = [
   flagSpec "LiberalTypeSynonyms"              Opt_LiberalTypeSynonyms,
   flagSpec "MagicHash"                        Opt_MagicHash,
   flagSpec "MonadComprehensions"              Opt_MonadComprehensions,
+  flagSpec "MonadFailDesugaring"              Opt_MonadFailDesugaring,
   flagSpec "MonoLocalBinds"                   Opt_MonoLocalBinds,
   flagSpec' "MonoPatBinds"                    Opt_MonoPatBinds
     (\ turn_on -> when turn_on $
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 8f29a270e0..da9424d5bc 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -78,6 +78,9 @@ module Lexer (
 import Control.Applicative
 #endif
 import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import Control.Monad.Fail
+#endif
 import Data.Bits
 import Data.Char
 import Data.List
@@ -1755,6 +1758,11 @@ instance Monad P where
   (>>=) = thenP
   fail = failP
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail P where
+  fail = failP
+#endif
+
 returnP :: a -> P a
 returnP a = a `seq` (P $ \s -> POk s a)
 
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 346f3a382d..1b1ffaabdf 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -239,10 +239,11 @@ basicKnownKeyNames
         apAName,
 
         -- Monad stuff
-        thenIOName, bindIOName, returnIOName, failIOName,
-        failMName, bindMName, thenMName, returnMName,
-        fmapName,
-        joinMName,
+        thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,
+        returnMName, fmapName, joinMName,
+
+        -- MonadFail
+        monadFailClassName, failMName, failMName_preMFP,
 
         -- MonadFix
         monadFixClassName, mfixName,
@@ -408,7 +409,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
     gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
     tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
-    rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
+    rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
     aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
     cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module
 
@@ -456,6 +457,7 @@ gHC_WORD        = mkBaseModule (fsLit "GHC.Word")
 mONAD           = mkBaseModule (fsLit "Control.Monad")
 mONAD_FIX       = mkBaseModule (fsLit "Control.Monad.Fix")
 mONAD_ZIP       = mkBaseModule (fsLit "Control.Monad.Zip")
+mONAD_FAIL      = mkBaseModule (fsLit "Control.Monad.Fail")
 aRROW           = mkBaseModule (fsLit "Control.Arrow")
 cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative")
 gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
@@ -566,11 +568,12 @@ map_RDR, append_RDR :: RdrName
 map_RDR                 = varQual_RDR gHC_BASE (fsLit "map")
 append_RDR              = varQual_RDR gHC_BASE (fsLit "++")
 
-foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR :: RdrName
+foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP, failM_RDR:: RdrName
 foldr_RDR               = nameRdrName foldrName
 build_RDR               = nameRdrName buildName
 returnM_RDR             = nameRdrName returnMName
 bindM_RDR               = nameRdrName bindMName
+failM_RDR_preMFP        = nameRdrName failMName_preMFP
 failM_RDR               = nameRdrName failMName
 
 left_RDR, right_RDR :: RdrName
@@ -912,12 +915,17 @@ functorClassName  = clsQual gHC_BASE    (fsLit "Functor") functorClassKey
 fmapName          = varQual gHC_BASE    (fsLit "fmap")    fmapClassOpKey
 
 -- Class Monad
-monadClassName, thenMName, bindMName, returnMName, failMName :: Name
+monadClassName, thenMName, bindMName, returnMName, failMName_preMFP :: Name
 monadClassName     = clsQual gHC_BASE (fsLit "Monad")  monadClassKey
 thenMName          = varQual gHC_BASE (fsLit ">>")     thenMClassOpKey
 bindMName          = varQual gHC_BASE (fsLit ">>=")    bindMClassOpKey
 returnMName        = varQual gHC_BASE (fsLit "return") returnMClassOpKey
-failMName          = varQual gHC_BASE (fsLit "fail")   failMClassOpKey
+failMName_preMFP   = varQual gHC_BASE (fsLit "fail")   failMClassOpKey_preMFP
+
+-- Class MonadFail
+monadFailClassName, failMName :: Name
+monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey
+failMName          = varQual mONAD_FAIL (fsLit "fail")      failMClassOpKey
 
 -- Classes (Applicative, Foldable, Traversable)
 applicativeClassName, foldableClassName, traversableClassName :: Name
@@ -1385,6 +1393,9 @@ typeable7ClassKey       = mkPreludeClassUnique 27
 monadFixClassKey :: Unique
 monadFixClassKey        = mkPreludeClassUnique 28
 
+monadFailClassKey :: Unique
+monadFailClassKey       = mkPreludeClassUnique 29
+
 monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique
 monadPlusClassKey       = mkPreludeClassUnique 30
 randomClassKey          = mkPreludeClassUnique 31
@@ -1951,14 +1962,14 @@ uniques so we can look them up easily when we want to conjure them up
 during type checking.
 -}
 
-        -- Just a place holder for  unbound variables  produced by the renamer:
+-- Just a placeholder for unbound variables produced by the renamer:
 unboundKey :: Unique
 unboundKey                    = mkPreludeMiscIdUnique 158
 
 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
     enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
     enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
-    failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
+    failMClassOpKey_preMFP, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
     fmapClassOpKey
     :: Unique
 fromIntegerClassOpKey         = mkPreludeMiscIdUnique 160
@@ -1971,7 +1982,7 @@ enumFromThenToClassOpKey      = mkPreludeMiscIdUnique 166
 eqClassOpKey                  = mkPreludeMiscIdUnique 167
 geClassOpKey                  = mkPreludeMiscIdUnique 168
 negateClassOpKey              = mkPreludeMiscIdUnique 169
-failMClassOpKey               = mkPreludeMiscIdUnique 170
+failMClassOpKey_preMFP        = mkPreludeMiscIdUnique 170
 bindMClassOpKey               = mkPreludeMiscIdUnique 171 -- (>>=)
 thenMClassOpKey               = mkPreludeMiscIdUnique 172 -- (>>)
 fmapClassOpKey                = mkPreludeMiscIdUnique 173
@@ -1981,6 +1992,10 @@ returnMClassOpKey             = mkPreludeMiscIdUnique 174
 mfixIdKey :: Unique
 mfixIdKey       = mkPreludeMiscIdUnique 175
 
+-- MonadFail operations
+failMClassOpKey :: Unique
+failMClassOpKey = mkPreludeMiscIdUnique 176
+
 -- Arrow notation
 arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,
     loopAIdKey :: Unique
@@ -2086,7 +2101,7 @@ standardClassKeys :: [Unique]
 standardClassKeys = derivableClassKeys ++ numericClassKeys
                   ++ [randomClassKey, randomGenClassKey,
                       functorClassKey,
-                      monadClassKey, monadPlusClassKey,
+                      monadClassKey, monadPlusClassKey, monadFailClassKey,
                       isStringClassKey,
                       applicativeClassKey, foldableClassKey,
                       traversableClassKey, alternativeClassKey
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 919a1d51fe..68140f73f3 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -55,6 +55,9 @@ import Control.Applicative ( Applicative(..), Alternative(..) )
 #endif
 
 import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
 import Data.Bits as Bits
 import qualified Data.ByteString as BS
 import Data.Int
@@ -653,6 +656,11 @@ instance Monad RuleM where
     Just r -> runRuleM (g r) dflags iu e
   fail _ = mzero
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail RuleM where
+    fail _ = mzero
+#endif
+
 instance Alternative RuleM where
     empty = mzero
     (<|>) = mplus
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 1e8eb27e9f..c0d88e9f35 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -1441,8 +1441,8 @@ lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
 -- case we desugar directly rather than calling an existing function
 -- Hence the (Maybe (SyntaxExpr Name)) return type
 lookupIfThenElse
-  = do { rebind <- xoptM Opt_RebindableSyntax
-       ; if not rebind
+  = do { rebindable_on <- xoptM Opt_RebindableSyntax
+       ; if not rebindable_on
          then return (Nothing, emptyFVs)
          else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
                  ; return (Just (HsVar ite), unitFV ite) } }
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index d748bf0bc0..a8b1d2e7c8 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -10,7 +10,8 @@ general, all of these functions return a renamed thing, and a set of
 free variables.
 -}
 
-{-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module RnExpr (
         rnLExpr, rnExpr, rnStmts
@@ -787,7 +788,12 @@ 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
-        ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
+
+        ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
+        ; let failFunction | xMonadFailEnabled = failMName
+                           | otherwise         = failMName_preMFP
+        ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
         ; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)]
@@ -1091,7 +1097,12 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
   = do { (body', fv_expr) <- rnBody body
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
-       ; (fail_op, fvs2) <- lookupSyntaxName failMName
+
+       ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
+       ; let failFunction | xMonadFailEnabled = failMName
+                          | otherwise         = failMName_preMFP
+       ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+
        ; let bndrs = mkNameSet (collectPatBinders pat')
              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index 31d8212831..cb671be7a5 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -40,6 +40,9 @@ import State
 import Control.Applicative (Applicative(..))
 #endif
 import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
@@ -2088,6 +2091,11 @@ instance Monad SpecM where
     return = pure
     fail str = SpecM $ fail str
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail SpecM where
+    fail str = SpecM $ fail str
+#endif
+
 instance MonadUnique SpecM where
     getUniqueSupplyM
         = SpecM $ do st <- get
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index bb7a3744f0..0d6e185ab8 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -354,7 +354,7 @@ 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 pat_ty $
                             thing_inside res_ty
-        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+        ; return (mkBindStmt pat' rhs', thing) }
 
 tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
                             , recS_rec_ids = rec_names }) res_ty thing_inside
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 5fdd7def0d..011b70299f 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -463,12 +463,23 @@ mkGroupReporter mk_err ctxt cts
 
 reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
             -> [Ct] -> TcM ()
-reportGroup mk_err ctxt cts
-  = do { err <- mk_err ctxt cts
-       ; maybeReportError ctxt err
-       ; mapM_ (maybeAddDeferredBinding ctxt err) cts }
-               -- Add deferred bindings for all
-               -- But see Note [Always warn with -fdefer-type-errors]
+reportGroup mk_err ctxt cts =
+  case partition isMonadFailInstanceMissing cts of
+        -- Only warn about missing MonadFail constraint when
+        -- there are no other missing contstraints!
+        (monadFailCts, []) -> do { err <- mk_err ctxt monadFailCts
+                                 ; reportWarning err }
+
+        (_, cts') -> do { err <- mk_err ctxt cts'
+                        ; maybeReportError ctxt err
+                        ; mapM_ (maybeAddDeferredBinding ctxt err) cts' }
+                                -- Add deferred bindings for all
+                                -- But see Note [Always warn with -fdefer-type-errors]
+  where
+    isMonadFailInstanceMissing ct =
+        case ctLocOrigin (ctLoc ct) of
+            FailablePattern _pat -> True
+            _otherwise           -> False
 
 maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
 maybeReportHoleError ctxt ct err
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index d7dbddf6ec..b504206a2a 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -6,7 +6,9 @@
 TcMatches: Typecheck some @Matches@
 -}
 
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
                    TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
@@ -36,6 +38,10 @@ import Outputable
 import Util
 import SrcLoc
 import FastString
+import DynFlags
+import PrelNames (monadFailClassName)
+import Type
+import Inst
 
 -- Create chunkified tuple tybes for monad comprehensions
 import MkCore
@@ -517,15 +523,18 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
         ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op
                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 
-           -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
         ; fail_op' <- if isIrrefutableHsPat pat
-                      then return noSyntaxExpr
-                      else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
+            then return noSyntaxExpr
+            else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
 
         ; rhs' <- tcMonoExprNC rhs rhs_ty
+
         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
                            thing_inside new_res_ty
 
+        ; monadFailWarnings pat' new_res_ty
+
         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
 -- Boolean expressions.
@@ -764,16 +773,18 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
         ; bind_op'   <- tcSyntaxOp DoOrigin bind_op
                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 
-                -- If (but only if) the pattern can fail,
-                -- typecheck the 'fail' operator
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
         ; fail_op' <- if isIrrefutableHsPat pat
-                      then return noSyntaxExpr
-                      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
+            then return noSyntaxExpr
+            else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 
         ; rhs' <- tcMonoExprNC rhs rhs_ty
+
         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
                            thing_inside new_res_ty
 
+        ; monadFailWarnings pat' new_res_ty
+
         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
 tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
@@ -847,6 +858,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 tcDoStmt _ stmt _ _
   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 
+
+
 {-
 Note [Treat rebindable syntax first]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -859,6 +872,64 @@ Otherwise the error shows up when cheking the rebindable syntax, and
 the expected/inferred stuff is back to front (see Trac #3613).
 -}
 
+
+
+---------------------------------------------------
+-- MonadFail Proposal warnings
+---------------------------------------------------
+
+-- The idea behind issuing MonadFail warnings is that we add them whenever a
+-- failable pattern is encountered. However, instead of throwing a type error
+-- when the constraint cannot be satisfied, we only issue a warning in
+-- TcErrors.hs.
+
+monadFailWarnings :: LPat TcId -> TcType -> TcRn ()
+monadFailWarnings pat doExprType = unless (isIrrefutableHsPat pat) $ do
+    rebindableSyntax <- xoptM Opt_RebindableSyntax
+    desugarFlag      <- xoptM Opt_MonadFailDesugaring
+    missingWarning   <- woptM Opt_WarnMissingMonadFailInstance
+    if | rebindableSyntax && (desugarFlag || missingWarning)
+           -> warnRebindableClash pat
+       | not desugarFlag && missingWarning
+           -> addMonadFailConstraint pat doExprType
+       | otherwise        -> pure ()
+
+addMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()
+addMonadFailConstraint pat doExprType = do
+    doExprTypeHead <- tyHead <$> zonkType doExprType
+    monadFailClass <- tcLookupClass monadFailClassName
+    let predType = mkClassPred monadFailClass [doExprTypeHead]
+    _ <- emitWanted (FailablePattern pat) predType
+    pure ()
+
+warnRebindableClash :: LPat TcId -> TcRn ()
+warnRebindableClash pattern = addWarnAt (getLoc pattern)
+    (text "The failable pattern" <+> quotes (ppr pattern)
+     $$
+     nest 2 (text "is used together with -XRebindableSyntax."
+             <+> text "If this is intentional,"
+             $$
+             text "compile with -fno-warn-missing-monadfail-instance."))
+
+zonkType :: TcType -> TcRn TcType
+zonkType ty = do
+    tidyEnv <- tcInitTidyEnv
+    (_, zonkedType) <- zonkTidyTcType tidyEnv ty
+    pure zonkedType
+
+
+tyHead :: TcType -> TcType
+tyHead ty
+    | Just (con, _) <- splitAppTy_maybe ty = con
+    | Just _ <- splitFunTy_maybe ty        = panicFor "FunTy"
+    | Just _ <- splitTyConApp_maybe ty     = panicFor "TyConApp"
+    | Just _ <- splitForAllTy_maybe ty     = panicFor "ForAllTy"
+    | otherwise                            = panicFor "<some other>"
+
+    where panicFor x = panic ("MonadFail check applied to " ++ x ++ " type")
+
+
+
 {-
 Note [typechecking ApplicativeStmt]
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 1b2a8d993e..a15fa7c923 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -76,7 +76,7 @@ import RnEnv
 import RnSource
 import ErrUtils
 import Id
-import IdInfo( IdDetails( VanillaId ) )
+import IdInfo
 import VarEnv
 import Module
 import UniqFM
@@ -103,7 +103,6 @@ import FastString
 import Maybes
 import Util
 import Bag
-import IdInfo
 
 import Control.Monad
 
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 66635a0e6c..18ba7cec63 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -147,6 +147,9 @@ import FastString
 import GHC.Fingerprint
 
 import Control.Monad (ap, liftM, msum)
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
 
 #ifdef GHCI
 import Data.Map      ( Map )
@@ -2263,6 +2266,8 @@ data CtOrigin
   | UnboundOccurrenceOf RdrName
   | ListOrigin          -- An overloaded list
   | StaticOrigin        -- A static form
+  | FailablePattern (LPat TcId) -- A failable pattern in do-notation for the
+                                -- MonadFail Proposal (MFP)
 
 ctoHerald :: SDoc
 ctoHerald = ptext (sLit "arising from")
@@ -2352,6 +2357,8 @@ pprCtO AnnOrigin             = ptext (sLit "an annotation")
 pprCtO HoleOrigin            = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
 pprCtO ListOrigin            = ptext (sLit "an overloaded list")
 pprCtO StaticOrigin          = ptext (sLit "a static form")
+pprCtO (FailablePattern pat) = text "the failable pattern" <+> quotes (ppr pat)
+                               $$ text "(this will become an error a future GHC release)"
 pprCtO _                     = panic "pprCtOrigin"
 
 {-
@@ -2380,6 +2387,11 @@ instance Monad TcPluginM where
     TcPluginM (\ ev -> do a <- m ev
                           runTcPluginM (k a) ev)
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail TcPluginM where
+  fail x   = TcPluginM (const $ fail x)
+#endif
+
 runTcPluginM :: TcPluginM a -> Maybe EvBindsVar -> TcM a
 runTcPluginM (TcPluginM m) = m
 
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index ec1ef18890..7f2dd66228 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -144,6 +144,9 @@ import Maybes ( orElse, firstJusts )
 import TrieMap
 import Control.Arrow ( first )
 import Control.Monad( ap, when, unless, MonadPlus(..) )
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
 import MonadUtils
 import Data.IORef
 import Data.List ( foldl', partition )
@@ -2166,6 +2169,11 @@ instance Monad TcS where
   fail err  = TcS (\_ -> fail err)
   m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail TcS where
+  fail err  = TcS (\_ -> fail err)
+#endif
+
 instance MonadUnique TcS where
    getUniqueSupplyM = wrapTcS getUniqueSupplyM
 
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index 87681e0eb8..a29c85f2da 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -34,6 +34,9 @@ import Outputable
 import FastString (sLit)
 
 import Control.Monad (liftM, foldM, ap)
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
 #if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
 #endif
@@ -729,6 +732,11 @@ instance Monad UM where
                                other                   -> other
                            SurelyApart -> SurelyApart)
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail UM where
+    fail _   = UM (\_tvs _subst -> SurelyApart) -- failed pattern match
+#endif
+
 -- returns an idempotent substitution
 initUM :: (TyVar -> BindFlag) -> UM () -> UnifyResult
 initUM badtvs um = fmap (niFixTvSubst . snd) $ unUM um badtvs emptyTvSubstEnv
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 31ac2b3731..804ddd8e70 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -43,6 +43,9 @@ import Data.Typeable
 import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
 import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
 import MonadUtils
 import Control.Applicative (Alternative(..))
 
@@ -62,6 +65,12 @@ instance Monad (IOEnv m) where
     return = pure
     fail _ = failM -- Ignore the string
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail (IOEnv m) where
+    fail _ = failM -- Ignore the string
+#endif
+
+
 instance Applicative (IOEnv m) where
     pure = returnM
     IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index 56b6dab5d9..656f40a372 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -20,6 +20,9 @@ module Maybes (
 
 import Control.Applicative
 import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import Control.Monad.Fail
+#endif
 import Data.Maybe
 
 infixr 4 `orElse`
@@ -85,6 +88,12 @@ instance (Monad m) => Monad (MaybeT m) where
   x >>= f = MaybeT $ runMaybeT x >>= maybe (pure Nothing) (runMaybeT . f)
   fail _ = MaybeT $ pure Nothing
 
+
+#if __GLASGOW_HASKELL__ > 710
+instance Monad m => MonadFail (MaybeT m) where
+  fail _ = MaybeT $ return Nothing
+#endif
+
 #if __GLASGOW_HASKELL__ < 710
 -- Pre-AMP change
 instance (Monad m, Applicative m) => Alternative (MaybeT m) where
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index ed47dae6a0..70879b12e8 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -1681,6 +1681,22 @@ In the case of transform comprehensions, notice that the groups are
 parameterised over some arbitrary type ``n`` (provided it has an
 ``fmap``, as well as the comprehension being over an arbitrary monad.
 
+.. _monadfail-desugaring
+
+New monadic failure desugaring mechanism
+----------------------------------------
+
+.. index::
+    single: -XMonadFailDesugaring option
+
+Switch desugaring of ``do``-blocks to use ``MonadFail.fail`` instead of
+``Monad.fail``. This will be the default behaviour in a future GHC release,
+under the MonadFail Proposal (MFP).
+
+This extension is temporary, and will be deprecated in a future release. It is
+included so that library authors have a hard check for whether their code
+will work with future GHC versions.
+
 .. _rebindable-syntax:
 
 Rebindable syntax and the implicit Prelude import
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index c3271d0111..8cf329cdc7 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -188,12 +188,22 @@ command line.
        single: AMP
        single: Applicative-Monad Proposal
 
-    Causes a warning to be emitted when a definition is in conflict with
-    the AMP (Applicative-Monad proosal), namely: 1. Instance of Monad
-    without Applicative; 2. Instance of MonadPlus without Alternative;
-    3. Custom definitions of join/pure/<\*>
+    This option is deprecated.
 
-    This option is on by default.
+    Caused a warning to be emitted when a definition was in conflict with
+    the AMP (Applicative-Monad proosal).
+
+``-fwarn-missing-monadfail-instance``
+    .. index::
+       single: -fwarn-missing-monadfail-instance
+       single: MFP
+       single: MonadFail Proposal
+
+    Warn when a failable pattern is used in a do-block that does not have a
+    ``MonadFail`` instance.
+
+    This option is off by default, but will be switched on in a future GHC
+    release, as part of the MFP (MonadFail Proposal).
 
 ``-fwarn-deprecated-flags``
     .. index::
diff --git a/libraries/base/Control/Monad.hs b/libraries/base/Control/Monad.hs
index 7de41bacc6..6957ad464f 100644
--- a/libraries/base/Control/Monad.hs
+++ b/libraries/base/Control/Monad.hs
@@ -75,8 +75,8 @@ module Control.Monad
     , (<$!>)
     ) where
 
-import Data.Functor ( void, (<$>) )
 import Data.Foldable ( Foldable, sequence_, sequenceA_, msum, mapM_, foldlM, forM_ )
+import Data.Functor ( void, (<$>) )
 import Data.Traversable ( forM, mapM, traverse, sequence, sequenceA )
 
 import GHC.Base hiding ( mapM, sequence )
diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs
index bae2abc90e..3908b24408 100644
--- a/libraries/base/Text/ParserCombinators/ReadP.hs
+++ b/libraries/base/Text/ParserCombinators/ReadP.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE DeriveFunctor #-}
@@ -76,6 +77,10 @@ import GHC.Unicode ( isSpace )
 import GHC.List ( replicate, null )
 import GHC.Base hiding ( many )
 
+#if __GLASGOW_HASKELL__ > 710
+import Control.Monad.Fail
+#endif
+
 infixr 5 +++, <++
 
 ------------------------------------------------------------------------
@@ -119,6 +124,11 @@ instance Monad P where
 
   fail _ = Fail
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail P where
+  fail _ = Fail
+#endif
+
 instance Alternative P where
   empty = Fail
 
@@ -166,6 +176,11 @@ instance Monad ReadP where
   fail _    = R (\_ -> Fail)
   R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail ReadP where
+  fail _    = R (\_ -> Fail)
+#endif
+
 instance Alternative ReadP where
     empty = mzero
     (<|>) = mplus
diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs
index 02268364ca..a1ce920ce2 100644
--- a/libraries/base/Text/ParserCombinators/ReadPrec.hs
+++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -64,6 +65,10 @@ import qualified Text.ParserCombinators.ReadP as ReadP
 import GHC.Num( Num(..) )
 import GHC.Base
 
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
+
 -- ---------------------------------------------------------------------------
 -- The readPrec type
 
@@ -82,6 +87,11 @@ instance Monad ReadPrec where
   fail s    = P (\_ -> fail s)
   P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)
 
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail ReadPrec where
+  fail s    = P (\_ -> fail s)
+#endif
+
 instance MonadPlus ReadPrec where
   mzero = pfail
   mplus = (+++)
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index f76dc34354..d3bee2a61a 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -33,7 +33,9 @@ expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
-                             "OverloadedLabels"]
+                             "OverloadedLabels",
+                             "Strict",
+                             "MonadFailDesugaring"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/monadfail/MonadFailErrors.hs b/testsuite/tests/monadfail/MonadFailErrors.hs
new file mode 100644
index 0000000000..f9db31e5a0
--- /dev/null
+++ b/testsuite/tests/monadfail/MonadFailErrors.hs
@@ -0,0 +1,95 @@
+-- Test purpose:
+-- Break properly if MonadFail is live
+
+{-# LANGUAGE MonadFailDesugaring #-}
+
+module MonadFailWarnings where
+
+import Control.Monad.Fail
+import Control.Monad.ST
+import Data.Functor.Identity
+
+
+
+general :: Monad m => m a
+general = do
+    Just x <- undefined
+    undefined
+
+
+
+general' :: MonadFail m => m a
+general' = do
+    Just x <- undefined
+    undefined
+
+
+
+identity :: Identity a
+identity = do
+    Just x <- undefined
+    undefined
+
+
+
+io :: IO a
+io = do
+    Just x <- undefined
+    undefined
+
+
+
+st :: ST s a
+st = do
+    Just x <- undefined
+    undefined
+
+
+
+reader :: r -> a
+reader = do
+    Just x <- undefined
+    undefined
+
+
+
+newtype Newtype a = Newtype a
+newtypeMatch :: Identity a
+newtypeMatch = do
+    Newtype x <- undefined
+    undefined
+
+
+
+data Data a = Data a
+singleConMatch :: Identity a
+singleConMatch = do
+    Data x <- undefined
+    undefined
+
+
+
+data Maybe' a = Nothing' | Just' a
+instance Functor Maybe' where fmap = undefined
+instance Applicative Maybe' where pure = undefined; (<*>) = undefined
+instance Monad Maybe' where (>>=) = undefined
+instance MonadFail Maybe' where fail = undefined
+customFailable :: Maybe' a
+customFailable = do
+    Just x <- undefined
+    undefined
+
+
+wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a
+wildcardx = do
+    x <- undefined
+    undefined
+explicitlyIrrefutable = do
+    ~(x:y) <- undefined
+    undefined
+wildcard_ = do
+    _ <- undefined
+    undefined
+tuple = do
+    (a,b) <- undefined
+    undefined
diff --git a/testsuite/tests/monadfail/MonadFailErrors.stderr b/testsuite/tests/monadfail/MonadFailErrors.stderr
new file mode 100644
index 0000000000..ad661772c7
--- /dev/null
+++ b/testsuite/tests/monadfail/MonadFailErrors.stderr
@@ -0,0 +1,74 @@
+
+MonadFailErrors.hs:16:5: error:
+    Could not deduce (MonadFail m) arising from a do statement
+    from the context: Monad m
+      bound by the type signature for:
+                 general :: Monad m => m a
+      at MonadFailErrors.hs:14:12-25
+    Possible fix:
+      add (MonadFail m) to the context of
+        the type signature for:
+          general :: Monad m => m a
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘general’:
+        general
+          = do { Just x <- undefined;
+                 undefined }
+
+MonadFailErrors.hs:30:5: error:
+    No instance for (MonadFail Identity) arising from a do statement
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘identity’:
+        identity
+          = do { Just x <- undefined;
+                 undefined }
+
+MonadFailErrors.hs:44:5: error:
+    No instance for (MonadFail (ST s)) arising from a do statement
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘st’:
+        st
+          = do { Just x <- undefined;
+                 undefined }
+
+MonadFailErrors.hs:51:5: error:
+    No instance for (MonadFail ((->) r)) arising from a do statement
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘reader’:
+        reader
+          = do { Just x <- undefined;
+                 undefined }
+
+MonadFailErrors.hs:59:5: error:
+    No instance for (MonadFail Identity) arising from a do statement
+    In a stmt of a 'do' block: Newtype x <- undefined
+    In the expression:
+      do { Newtype x <- undefined;
+           undefined }
+    In an equation for ‘newtypeMatch’:
+        newtypeMatch
+          = do { Newtype x <- undefined;
+                 undefined }
+
+MonadFailErrors.hs:67:5: error:
+    No instance for (MonadFail Identity) arising from a do statement
+    In a stmt of a 'do' block: Data x <- undefined
+    In the expression:
+      do { Data x <- undefined;
+           undefined }
+    In an equation for ‘singleConMatch’:
+        singleConMatch
+          = do { Data x <- undefined;
+                 undefined }
diff --git a/testsuite/tests/monadfail/MonadFailWarnings.hs b/testsuite/tests/monadfail/MonadFailWarnings.hs
new file mode 100644
index 0000000000..3b786cc8c7
--- /dev/null
+++ b/testsuite/tests/monadfail/MonadFailWarnings.hs
@@ -0,0 +1,107 @@
+-- Test purpose:
+-- Ensure that MonadFail warnings are issued correctly if the warning flag
+-- is enabled
+
+{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-}
+
+module MonadFailWarnings where
+
+import Control.Monad.Fail
+import Control.Monad.ST
+import Data.Functor.Identity
+
+
+
+-- should warn, because the do-block gets a general Monad constraint,
+-- but should have MonadFail
+general :: Monad m => m a
+general = do
+    Just x <- undefined
+    undefined
+
+
+
+-- should NOT warn, because the constraint is correct
+general' :: MonadFail m => m a
+general' = do
+    Just x <- undefined
+    undefined
+
+
+
+-- should warn, because Identity isn't MonadFail
+identity :: Identity a
+identity = do
+    Just x <- undefined
+    undefined
+
+
+
+-- should NOT warn, because IO is MonadFail
+io :: IO a
+io = do
+    Just x <- undefined
+    undefined
+
+
+
+-- should warn, because (ST s) is not MonadFail
+st :: ST s a
+st = do
+    Just x <- undefined
+    undefined
+
+
+
+-- should warn, because (r ->) is not MonadFail
+reader :: r -> a
+reader = do
+    Just x <- undefined
+    undefined
+
+
+
+-- should NOT warn, because matching against newtype
+newtype Newtype a = Newtype a
+newtypeMatch :: Identity a
+newtypeMatch = do
+    Newtype x <- undefined
+    undefined
+
+
+
+-- should NOT warn, because Data has only one constructor
+data Data a = Data a
+singleConMatch :: Identity a
+singleConMatch = do
+    Data x <- undefined
+    undefined
+
+
+
+-- should NOT warn, because Maybe' has a MonadFail instance
+data Maybe' a = Nothing' | Just' a
+instance Functor Maybe' where fmap = undefined
+instance Applicative Maybe' where pure = undefined; (<*>) = undefined
+instance Monad Maybe' where (>>=) = undefined
+instance MonadFail Maybe' where fail = undefined
+customFailable :: Maybe' a
+customFailable = do
+    Just x <- undefined
+    undefined
+
+
+-- should NOT warn, because patterns always match
+wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a
+wildcardx = do
+    x <- undefined
+    undefined
+explicitlyIrrefutable = do
+    ~(x:y) <- undefined
+    undefined
+wildcard_ = do
+    _ <- undefined
+    undefined
+tuple = do
+    (a,b) <- undefined
+    undefined
diff --git a/testsuite/tests/monadfail/MonadFailWarnings.stderr b/testsuite/tests/monadfail/MonadFailWarnings.stderr
new file mode 100644
index 0000000000..94858c1945
--- /dev/null
+++ b/testsuite/tests/monadfail/MonadFailWarnings.stderr
@@ -0,0 +1,60 @@
+
+MonadFailWarnings.hs:19:5: warning:
+    Could not deduce (MonadFail m)
+      arising from the failable pattern ‘Just x’
+                   (this will become an error a future GHC release)
+    from the context: Monad m
+      bound by the type signature for:
+                 general :: Monad m => m a
+      at MonadFailWarnings.hs:17:12-25
+    Possible fix:
+      add (MonadFail m) to the context of
+        the type signature for:
+          general :: Monad m => m a
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘general’:
+        general
+          = do { Just x <- undefined;
+                 undefined }
+
+MonadFailWarnings.hs:35:5: warning:
+    No instance for (MonadFail Identity)
+      arising from the failable pattern ‘Just x’
+                   (this will become an error a future GHC release)
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘identity’:
+        identity
+          = do { Just x <- undefined;
+                 undefined }
+
+MonadFailWarnings.hs:51:5: warning:
+    No instance for (MonadFail (ST s))
+      arising from the failable pattern ‘Just x’
+                   (this will become an error a future GHC release)
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘st’:
+        st
+          = do { Just x <- undefined;
+                 undefined }
+
+MonadFailWarnings.hs:59:5: warning:
+    No instance for (MonadFail ((->) r))
+      arising from the failable pattern ‘Just x’
+                   (this will become an error a future GHC release)
+    In a stmt of a 'do' block: Just x <- undefined
+    In the expression:
+      do { Just x <- undefined;
+           undefined }
+    In an equation for ‘reader’:
+        reader
+          = do { Just x <- undefined;
+                 undefined }
diff --git a/testsuite/tests/monadfail/MonadFailWarningsDisabled.hs b/testsuite/tests/monadfail/MonadFailWarningsDisabled.hs
new file mode 100644
index 0000000000..d3df107a4a
--- /dev/null
+++ b/testsuite/tests/monadfail/MonadFailWarningsDisabled.hs
@@ -0,0 +1,94 @@
+-- Test purpose:
+-- Make sure that not enabling MonadFail warnings makes code compile just
+-- as it did in < 8.0
+
+module MonadFailWarnings where
+
+import Control.Monad.Fail
+import Control.Monad.ST
+import Data.Functor.Identity
+
+
+
+general :: Monad m => m a
+general = do
+    Just x <- undefined
+    undefined
+
+
+
+general' :: MonadFail m => m a
+general' = do
+    Just x <- undefined
+    undefined
+
+
+
+identity :: Identity a
+identity = do
+    Just x <- undefined
+    undefined
+
+
+
+io :: IO a
+io = do
+    Just x <- undefined
+    undefined
+
+
+
+st :: ST s a
+st = do
+    Just x <- undefined
+    undefined
+
+
+
+reader :: r -> a
+reader = do
+    Just x <- undefined
+    undefined
+
+
+
+newtype Newtype a = Newtype a
+newtypeMatch :: Identity a
+newtypeMatch = do
+    Newtype x <- undefined
+    undefined
+
+
+
+data Data a = Data a
+singleConMatch :: Identity a
+singleConMatch = do
+    Data x <- undefined
+    undefined
+
+
+
+data Maybe' a = Nothing' | Just' a
+instance Functor Maybe' where fmap = undefined
+instance Applicative Maybe' where pure = undefined; (<*>) = undefined
+instance Monad Maybe' where (>>=) = undefined
+instance MonadFail Maybe' where fail = undefined
+customFailable :: Maybe' a
+customFailable = do
+    Just x <- undefined
+    undefined
+
+
+wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a
+wildcardx = do
+    x <- undefined
+    undefined
+explicitlyIrrefutable = do
+    ~(x:y) <- undefined
+    undefined
+wildcard_ = do
+    _ <- undefined
+    undefined
+tuple = do
+    (a,b) <- undefined
+    undefined
diff --git a/testsuite/tests/monadfail/MonadFailWarningsWithRebindableSyntax.hs b/testsuite/tests/monadfail/MonadFailWarningsWithRebindableSyntax.hs
new file mode 100644
index 0000000000..c9f25027f9
--- /dev/null
+++ b/testsuite/tests/monadfail/MonadFailWarningsWithRebindableSyntax.hs
@@ -0,0 +1,14 @@
+-- Test purpose:
+-- RebindableSyntax does not play that well with MonadFail, so here we ensure
+-- that when both settings are enabled we get the proper warning.
+
+{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-}
+{-# LANGUAGE RebindableSyntax #-}
+
+module MonadFailWarningsWithRebindableSyntax where
+
+import Prelude
+
+test1 f g = do
+    Just x <- f
+    g
diff --git a/testsuite/tests/monadfail/MonadFailWarningsWithRebindableSyntax.stderr b/testsuite/tests/monadfail/MonadFailWarningsWithRebindableSyntax.stderr
new file mode 100644
index 0000000000..819c878dc9
--- /dev/null
+++ b/testsuite/tests/monadfail/MonadFailWarningsWithRebindableSyntax.stderr
@@ -0,0 +1,5 @@
+
+MonadFailWarningsWithRebindableSyntax.hs:13:5: warning:
+    The failable pattern ‘Just x’
+      is used together with -XRebindableSyntax. If this is intentional,
+      compile with -fno-warn-missing-monadfail-instance.
diff --git a/testsuite/tests/monadfail/all.T b/testsuite/tests/monadfail/all.T
new file mode 100644
index 0000000000..32eddb9e98
--- /dev/null
+++ b/testsuite/tests/monadfail/all.T
@@ -0,0 +1,4 @@
+test('MonadFailWarnings', normal, compile, [''])
+test('MonadFailErrors', normal, compile_fail, [''])
+test('MonadFailWarningsDisabled', normal, compile, [''])
+test('MonadFailWarningsWithRebindableSyntax', normal, compile, [''])
diff --git a/testsuite/tests/rebindable/rebindable1.hs b/testsuite/tests/rebindable/rebindable1.hs
index 1fb0b596fb..7bf3e237a6 100644
--- a/testsuite/tests/rebindable/rebindable1.hs
+++ b/testsuite/tests/rebindable/rebindable1.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-missing-monadfail-instance #-}
 {-# LANGUAGE RebindableSyntax, NPlusKPatterns #-}
 
 module RebindableCase1 where
@@ -11,7 +12,7 @@ module RebindableCase1 where
 	infixl 1 >>=;
 	(>>=) :: a;
 	(>>=) = undefined;
-	
+
 	infixl 1 >>;
 	(>>) :: a;
 	(>>) = undefined;
@@ -38,9 +39,9 @@ module RebindableCase1 where
 		Just a <- g;
 		return a;
 		};
-	
+
 	test_fromInteger = 1;
-	
+
 	test_fromRational = 0.5;
 
 	test_negate a = - a;
diff --git a/testsuite/tests/rebindable/rebindable6.hs b/testsuite/tests/rebindable/rebindable6.hs
index ffd69f904b..ec975e7f37 100644
--- a/testsuite/tests/rebindable/rebindable6.hs
+++ b/testsuite/tests/rebindable/rebindable6.hs
@@ -1,15 +1,18 @@
-{-# LANGUAGE RebindableSyntax, NPlusKPatterns, RankNTypes,
-             ScopedTypeVariables, FlexibleInstances #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NPlusKPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 module Main where
 	{
---	import Prelude;
 	import qualified Prelude;
 	import Prelude(String,undefined,Maybe(..),IO,putStrLn,
 		Integer,(++),Rational, (==), (>=) );
 
 	debugFunc :: String -> IO a -> IO a;
 	debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>>
-		(ioa Prelude.>>= (\a -> 
+		(ioa Prelude.>>= (\a ->
 			(putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a)
 		));
 
@@ -18,7 +21,7 @@ module Main where
 
 	returnIO :: a -> IO a;
         returnIO = Prelude.return;
-	
+
 	class HasReturn a where
 		{
 		return :: a;
@@ -107,10 +110,10 @@ module Main where
 		Just (b::b) <- g;	-- >>= (and fail if g returns Nothing)
 		return b;		-- return
 		};
-	
+
 	test_fromInteger :: Integer;
 	test_fromInteger = 27;
-	
+
 	test_fromRational :: Rational;
 	test_fromRational = 31.5;
 
@@ -129,7 +132,7 @@ module Main where
 
 
 	doTest :: String -> IO a -> IO ();
-	doTest s ioa = 
+	doTest s ioa =
 		(putStrLn ("start test " ++ s))
 			Prelude.>>
 		ioa
@@ -137,7 +140,7 @@ module Main where
 		(putStrLn ("end test " ++ s));
 
 	main :: IO ();
-	main = 
+	main =
 		(doTest "test_do failure"
 			(test_do (Prelude.return ()) (Prelude.return Nothing))
 		)
diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr
index cf280a961d..269ea8ff05 100644
--- a/testsuite/tests/rebindable/rebindable6.stderr
+++ b/testsuite/tests/rebindable/rebindable6.stderr
@@ -1,18 +1,18 @@
 
-rebindable6.hs:106:17: error:
+rebindable6.hs:109:17: error:
     Ambiguous type variable ‘t0’ arising from a do statement
     prevents the constraint ‘(HasSeq
                                 (IO a -> t0 -> IO b))’ from being solved.
       (maybe you haven't applied a function to enough arguments?)
     Relevant bindings include
-      g :: IO (Maybe b) (bound at rebindable6.hs:104:19)
-      f :: IO a (bound at rebindable6.hs:104:17)
+      g :: IO (Maybe b) (bound at rebindable6.hs:107:19)
+      f :: IO a (bound at rebindable6.hs:107:17)
       test_do :: IO a -> IO (Maybe b) -> IO b
-        (bound at rebindable6.hs:104:9)
+        (bound at rebindable6.hs:107:9)
     Probable fix: use a type annotation to specify what ‘t0’ should be.
     These potential instance exist:
       instance HasSeq (IO a -> IO b -> IO b)
-        -- Defined at rebindable6.hs:52:18
+        -- Defined at rebindable6.hs:55:18
     In a stmt of a 'do' block: f
     In the expression:
       do { f;
@@ -24,7 +24,7 @@ rebindable6.hs:106:17: error:
                  Just (b :: b) <- g;
                  return b }
 
-rebindable6.hs:107:17: error:
+rebindable6.hs:110:17: error:
     Ambiguous type variable ‘t1’ arising from a do statement
     prevents the constraint ‘(HasFail
                                 ([Char] -> t1))’ from being solved.
@@ -32,7 +32,7 @@ rebindable6.hs:107:17: error:
     Probable fix: use a type annotation to specify what ‘t1’ should be.
     These potential instance exist:
       instance HasFail (String -> IO a)
-        -- Defined at rebindable6.hs:57:18
+        -- Defined at rebindable6.hs:60:18
     In a stmt of a 'do' block: Just (b :: b) <- g
     In the expression:
       do { f;
@@ -44,18 +44,18 @@ rebindable6.hs:107:17: error:
                  Just (b :: b) <- g;
                  return b }
 
-rebindable6.hs:108:17: error:
+rebindable6.hs:111:17: error:
     Ambiguous type variable ‘t1’ arising from a use of ‘return’
     prevents the constraint ‘(HasReturn (b -> t1))’ from being solved.
       (maybe you haven't applied a function to enough arguments?)
     Relevant bindings include
-      b :: b (bound at rebindable6.hs:107:23)
-      g :: IO (Maybe b) (bound at rebindable6.hs:104:19)
+      b :: b (bound at rebindable6.hs:110:23)
+      g :: IO (Maybe b) (bound at rebindable6.hs:107:19)
       test_do :: IO a -> IO (Maybe b) -> IO b
-        (bound at rebindable6.hs:104:9)
+        (bound at rebindable6.hs:107:9)
     Probable fix: use a type annotation to specify what ‘t1’ should be.
     These potential instance exist:
-      instance HasReturn (a -> IO a) -- Defined at rebindable6.hs:42:18
+      instance HasReturn (a -> IO a) -- Defined at rebindable6.hs:45:18
     In a stmt of a 'do' block: return b
     In the expression:
       do { f;