Turn on MonadFail desugaring by default

Summary:
This contains two commits:

----

Make GHC's code-base compatible w/ `MonadFail`

There were a couple of use-sites which implicitly used pattern-matches
in `do`-notation even though the underlying `Monad` didn't explicitly
support `fail`

This refactoring turns those use-sites into explicit case
discrimations and adds an `MonadFail` instance for `UniqSM`
(`UniqSM` was the worst offender so this has been postponed for a
follow-up refactoring)

---

Turn on MonadFail desugaring by default

This finally implements the phase scheduled for GHC 8.6 according to

https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail#Transitionalstrategy

This also preserves some tests that assumed MonadFail desugaring to be
active; all ghc boot libs were already made compatible with this
`MonadFail` long ago, so no changes were needed there.

Test Plan: Locally performed ./validate --fast

Reviewers: bgamari, simonmar, jrtc27, RyanGlScott

Reviewed By: bgamari

Subscribers: bgamari, RyanGlScott, rwbarton, thomie, carter

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

28 files changed, 141 insertions, 67 deletions

diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs
index 83e54a7002..664600147e 100644
--- a/compiler/basicTypes/UniqSupply.hs
+++ b/compiler/basicTypes/UniqSupply.hs
@@ -32,6 +32,7 @@ module UniqSupply (
 import GhcPrelude
 
 import Unique
+import Panic (panic)
 
 import GHC.IO
 
@@ -39,6 +40,7 @@ import MonadUtils
 import Control.Monad
 import Data.Bits
 import Data.Char
+import Control.Monad.Fail
 
 #include "Unique.h"
 
@@ -147,6 +149,10 @@ instance Applicative UniqSM where
                               (# xx, us'' #) -> (# ff xx, us'' #)
     (*>) = thenUs_
 
+-- TODO: try to get rid of this instance
+instance MonadFail UniqSM where
+    fail = panic
+
 -- | Run the 'UniqSM' action, returning the final 'UniqSupply'
 initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
 initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index f2287e0fbd..a8ec300157 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -86,8 +86,10 @@ cgTopRhsCon dflags id con args =
 
             mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
             mk_payload (FieldOff arg _) = do
-                CmmLit lit <- getArgAmode arg
-                return lit
+                amode <- getArgAmode arg
+                case amode of
+                  CmmLit lit -> return lit
+                  _          -> panic "StgCmmCon.cgTopRhsCon"
 
             nonptr_wds = tot_wds - ptr_wds
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index cc941a2e57..1a708670b3 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -29,7 +29,7 @@ module StgCmmMonad (
 
         mkCall, mkCmmCall,
 
-        forkClosureBody, forkLneBody, forkAlts, codeOnly,
+        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
 
         ConTagZ,
 
@@ -636,6 +636,15 @@ forkAlts branch_fcodes
                 -- NB foldl.  state is the *left* argument to stateIncUsage
         ; return branch_results }
 
+forkAltPair :: FCode a -> FCode a -> FCode (a,a)
+-- Most common use of 'forkAlts'; having this helper function avoids
+-- accidental use of failible pattern-matches in @do@-notation
+forkAltPair x y = do
+  xy' <- forkAlts [x,y]
+  case xy' of
+    [x',y'] -> return (x',y')
+    _ -> panic "forkAltPair"
+
 -- collect the code emitted by an FCode computation
 getCodeR :: FCode a -> FCode (a, CmmAGraph)
 getCodeR fcode
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index da18949846..6ed3ca7402 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -1929,10 +1929,9 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
     -- TODO: Optimize branch for common case of no aliasing.
     copy src dst dst_p src_p bytes = do
         dflags <- getDynFlags
-        [moveCall, cpyCall] <- forkAlts [
-            getCode $ emitMemmoveCall dst_p src_p bytes 1,
-            getCode $ emitMemcpyCall  dst_p src_p bytes 1
-            ]
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p bytes 1)
+            (getCode $ emitMemcpyCall  dst_p src_p bytes 1)
         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
 
 emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
@@ -2073,12 +2072,11 @@ doCopyMutableArrayOp = emitCopyArray copy
     -- TODO: Optimize branch for common case of no aliasing.
     copy src dst dst_p src_p bytes = do
         dflags <- getDynFlags
-        [moveCall, cpyCall] <- forkAlts [
-            getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
-            (wORD_SIZE dflags),
-            getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
-            (wORD_SIZE dflags)
-            ]
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
 
 emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
@@ -2136,12 +2134,11 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
     -- TODO: Optimize branch for common case of no aliasing.
     copy src dst dst_p src_p bytes = do
         dflags <- getDynFlags
-        [moveCall, cpyCall] <- forkAlts
-            [ getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
-              (wORD_SIZE dflags)
-            , getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
-              (wORD_SIZE dflags)
-            ]
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
 
 emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index ef9da21e9a..c3b1625333 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -81,6 +81,7 @@ import DynFlags
 import Data.List
 
 import Data.Char        ( ord )
+import Control.Monad.Fail ( MonadFail )
 
 infixl 4 `mkCoreApp`, `mkCoreApps`
 
@@ -601,7 +602,7 @@ mkFoldrExpr elt_ty result_ty c n list = do
            `App` list)
 
 -- | Make a 'build' expression applied to a locally-bound worker function
-mkBuildExpr :: (MonadThings m, MonadUnique m)
+mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)
             => Type                                     -- ^ Type of list elements to be built
             -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
                                                         -- of the binders for the build worker function, returns
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index b5c18e5d66..99ba96755f 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -292,11 +292,15 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
   tickish <- tickishType `liftM` getEnv
   if inline && tickish == ProfNotes then return (L pos funBind) else do
 
-  (fvs, mg@(MG { mg_alts = matches' })) <-
+  (fvs, mg) <-
         getFreeVars $
         addPathEntry name $
         addTickMatchGroup False (fun_matches funBind)
 
+  case mg of
+    MG {} -> return ()
+    _     -> panic "addTickLHsBind"
+
   blackListed <- isBlackListed pos
   exported_names <- liftM exports getEnv
 
@@ -315,7 +319,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
                 return Nothing
 
   let mbCons = maybe Prelude.id (:)
-  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
+  return $ L pos $ funBind { fun_matches = mg
                            , fun_tick = tick `mbCons` fun_tick funBind }
 
    where
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index f7cea3b567..476a9b2efd 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -125,9 +125,12 @@ mallocStrings hsc_env ulbcos = do
     return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
 
   spliceLit (BCONPtrStr _) = do
-    (RemotePtr p : rest) <- get
-    put rest
-    return (BCONPtrWord (fromIntegral p))
+    rptrs <- get
+    case rptrs of
+      (RemotePtr p : rest) -> do
+        put rest
+        return (BCONPtrWord (fromIntegral p))
+      _ -> panic "mallocStrings:spliceLit"
   spliceLit other = return other
 
   splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 5b4a10f05e..95c2e37136 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -308,8 +308,10 @@ cPprTerm printers_ = go 0 where
   go prec t = do
     let default_ = Just `liftM` pprTermM go prec t
         mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
-    Just doc <- firstJustM mb_customDocs
-    return$ cparen (prec>app_prec+1) doc
+    mdoc <- firstJustM mb_customDocs
+    case mdoc of
+      Nothing -> panic "cPprTerm"
+      Just doc -> return $ cparen (prec>app_prec+1) doc
 
   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
   firstJustM [] = return Nothing
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index dba1275c42..51de1f6850 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -571,7 +571,8 @@ genCallSimpleCast w t@(PrimTarget op) [dst] args = do
     (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
     (argsV', stmts4)            <- castVars Signed $ zip argsV [width]
     (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
-    ([retV'], stmts5)           <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast" retVs'
     let s2                       = Store retV' dstV
 
     let stmts = stmts2 `appOL` stmts4 `snocOL`
@@ -602,7 +603,8 @@ genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
     (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
     (argsV', stmts4)            <- castVars Signed $ zip argsV (const width <$> argsV)
     (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
-    ([retV'], stmts5)           <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'
     let s2                       = Store retV' dstV
 
     let stmts = stmts2 `appOL` stmts4 `snocOL`
@@ -1275,7 +1277,8 @@ genMachOp _ op [x] = case op of
 
         negateVec ty v2 negOp = do
             (vx, stmts1, top) <- exprToVar x
-            ([vx'], stmts2) <- castVars Signed [(vx, ty)]
+            (vxs', stmts2) <- castVars Signed [(vx, ty)]
+            let vx' = singletonPanic "genMachOp: negateVec" vxs'
             (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
             return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
 
@@ -1338,7 +1341,8 @@ genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
 genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
     vval <- exprToVarW val
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW Signed [(vval, LMVector l ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
     doExprW ty $ Extract vval' vidx
   where
     ty = widthToLlvmInt w
@@ -1346,7 +1350,8 @@ genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
 genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
     vval <- exprToVarW val
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW Signed [(vval, LMVector l ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
     doExprW ty $ Extract vval' vidx
   where
     ty = widthToLlvmFloat w
@@ -1356,7 +1361,8 @@ genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
     vval <- exprToVarW val
     velt <- exprToVarW elt
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW Signed [(vval, ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
     doExprW ty $ Insert vval' velt vidx
   where
     ty = LMVector l (widthToLlvmInt w)
@@ -1365,7 +1371,8 @@ genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
     vval <- exprToVarW val
     velt <- exprToVarW elt
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW Signed [(vval, ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
     doExprW ty $ Insert vval' velt vidx
   where
     ty = LMVector l (widthToLlvmFloat w)
@@ -1477,8 +1484,10 @@ genMachOp_slow opt op [x, y] = case op of
         binCastLlvmOp ty binOp = runExprData $ do
             vx <- exprToVarW x
             vy <- exprToVarW y
-            [vx', vy'] <- castVarsW Signed [(vx, ty), (vy, ty)]
-            doExprW ty $ binOp vx' vy'
+            vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
+            case vxy' of
+              [vx',vy'] -> doExprW ty $ binOp vx' vy'
+              _         -> panic "genMachOp_slow: binCastLlvmOp"
 
         -- | Need to use EOption here as Cmm expects word size results from
         -- comparisons while LLVM return i1. Need to extend to llvmWord type
@@ -1981,3 +1990,8 @@ doTrashStmts :: WriterT LlvmAccum LlvmM ()
 doTrashStmts = do
     stmts <- lift getTrashStmts
     tell $ LlvmAccum stmts mempty
+
+-- | Return element of single-element list; 'panic' if list is not a single-element list
+singletonPanic :: String -> [a] -> a
+singletonPanic _ [x] = x
+singletonPanic s _ = panic s
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index b6664f222e..66c67c352e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -2116,6 +2116,7 @@ languageExtensions (Just Haskell98)
     = [LangExt.ImplicitPrelude,
        -- See Note [When is StarIsType enabled]
        LangExt.StarIsType,
+       LangExt.MonadFailDesugaring,
        LangExt.MonomorphismRestriction,
        LangExt.NPlusKPatterns,
        LangExt.DatatypeContexts,
@@ -2132,6 +2133,7 @@ languageExtensions (Just Haskell2010)
     = [LangExt.ImplicitPrelude,
        -- See Note [When is StarIsType enabled]
        LangExt.StarIsType,
+       LangExt.MonadFailDesugaring,
        LangExt.MonomorphismRestriction,
        LangExt.DatatypeContexts,
        LangExt.TraditionalRecordSyntax,
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index bec52e6001..452ccb3e80 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -942,7 +942,11 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
         ValBinds noExt
                      (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
 
-  Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
+  pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
+  let (hvals_io, fix_env) = case pstmt of
+        Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env')
+        _ -> panic "compileParsedExprRemote"
+
   updateFixityEnv fix_env
   status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
   case status of
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 90d6b0d67b..98e062df62 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -423,7 +423,10 @@ genCCall target dest_regs args
                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
 
                 ForeignTarget expr _
-                 -> do  (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
+                 -> do  (dyn_c, dyn_rs) <- arg_to_int_vregs expr
+                        let dyn_r = case dyn_rs of
+                                      [dyn_r'] -> dyn_r'
+                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
 
                 PrimTarget mop
@@ -433,7 +436,10 @@ genCCall target dest_regs args
                                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
 
                                 Right mopExpr -> do
-                                        (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
+                                        (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr
+                                        let dyn_r = case dyn_rs of
+                                                      [dyn_r'] -> dyn_r'
+                                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
                                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
 
                         return lblOrMopExpr
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 8d3f1835ae..cf4c258d01 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -997,9 +997,13 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
 
         IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->
           ASSERT2(null rdr_fs, ppr rdr_fs) do
-           (name, AvailTC _ ns subflds, mb_parent)
+           (name, avail, mb_parent)
                <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)
 
+           let (ns,subflds) = case avail of
+                                AvailTC _ ns' subflds' -> (ns',subflds')
+                                Avail _                -> panic "filterImports"
+
            -- Look up the children in the sub-names of the parent
            let subnames = case ns of   -- The tc is first in ns,
                             [] -> []   -- if it is there at all
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
index ab6220e9b5..036c6511d3 100644
--- a/compiler/typecheck/TcGenFunctor.hs
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -9,6 +9,7 @@ The deriving code for the Functor, Foldable, and Traversable classes
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 module TcGenFunctor (
         FFoldType(..), functorLikeTraverse,
@@ -435,20 +436,24 @@ foldDataConArgs ft con
 mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
             -> State [RdrName] (LHsExpr GhcPs)
 -- (mkSimpleLam fn) returns (\x. fn(x))
-mkSimpleLam lam = do
-    (n:names) <- get
-    put names
-    body <- lam (nlHsVar n)
-    return (mkHsLam [nlVarPat n] body)
+mkSimpleLam lam =
+    get >>= \case
+      n:names -> do
+        put names
+        body <- lam (nlHsVar n)
+        return (mkHsLam [nlVarPat n] body)
+      _ -> panic "mkSimpleLam"
 
 mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
              -> State [RdrName] (LHsExpr GhcPs))
              -> State [RdrName] (LHsExpr GhcPs)
-mkSimpleLam2 lam = do
-    (n1:n2:names) <- get
-    put names
-    body <- lam (nlHsVar n1) (nlHsVar n2)
-    return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
+mkSimpleLam2 lam =
+    get >>= \case
+      n1:n2:names -> do
+        put names
+        body <- lam (nlHsVar n1) (nlHsVar n2)
+        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
+      _ -> panic "mkSimpleLam2"
 
 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
 --
diff --git a/docs/users_guide/8.6.1-notes.rst b/docs/users_guide/8.6.1-notes.rst
index 3a24384493..7faef04516 100644
--- a/docs/users_guide/8.6.1-notes.rst
+++ b/docs/users_guide/8.6.1-notes.rst
@@ -134,6 +134,11 @@ Language
 
   See :ghc-ticket:`13833`.
 
+- :extension:`MonadFailDesugaring` is now enabled by default. See
+  `MonadFail Proposal (MFP)
+  <https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>`__
+  for more details.
+
 Compiler
 ~~~~~~~~
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 30b3cf19c8..ca782a9399 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -1592,14 +1592,13 @@ New monadic failure desugaring mechanism
     when desugaring refutable patterns in ``do`` blocks.
 
 The ``-XMonadFailDesugaring`` extension switches the desugaring of
-``do``-blocks to use ``MonadFail.fail`` instead of ``Monad.fail``. This will
-eventually be the default behaviour in a future GHC release, under the
+``do``-blocks to use ``MonadFail.fail`` instead of ``Monad.fail``.
+
+This extension is enabled by default since GHC 8.6.1, under the
 `MonadFail Proposal (MFP)
 <https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>`__.
 
-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.
+This extension is temporary, and will be deprecated in a future release.
 
 .. _rebindable-syntax:
 
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index bcb6d6e38c..1f862de4cb 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -889,7 +889,10 @@ installInteractivePrint :: Maybe String -> Bool -> GHCi ()
 installInteractivePrint Nothing _  = return ()
 installInteractivePrint (Just ipFun) exprmode = do
   ok <- trySuccess $ do
-                (name:_) <- GHC.parseName ipFun
+                names <- GHC.parseName ipFun
+                let name = case names of
+                             name':_ -> name'
+                             [] -> panic "installInteractivePrint"
                 modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
                                       in he{hsc_IC = new_ic})
                 return Succeeded
@@ -3249,7 +3252,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
       case mb_span of
         Nothing  -> stepCmd []
         Just loc -> do
-           Just md <- getCurrentBreakModule
+           md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
            current_toplevel_decl <- enclosingTickSpan md loc
            doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
 
@@ -3740,7 +3743,7 @@ turnOffBreak loc = do
 
 getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)
 getModBreak m = do
-   Just mod_info <- GHC.getModuleInfo m
+   mod_info      <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
    let modBreaks  = GHC.modInfoModBreaks mod_info
    let arr        = GHC.modBreaks_flags modBreaks
    let ticks      = GHC.modBreaks_locs  modBreaks
diff --git a/testsuite/tests/annotations/should_run/annrun01.hs b/testsuite/tests/annotations/should_run/annrun01.hs
index 0dbd44dd92..9030a39c60 100644
--- a/testsuite/tests/annotations/should_run/annrun01.hs
+++ b/testsuite/tests/annotations/should_run/annrun01.hs
@@ -4,6 +4,7 @@ module Main where
 
 import GHC
 import MonadUtils  ( liftIO )
+import Data.Maybe
 import DynFlags    ( defaultFatalMessager, defaultFlushOut )
 import Annotations ( AnnTarget(..), CoreAnnTarget )
 import GHC.Serialized  ( deserializeWithData )
@@ -34,7 +35,7 @@ main = defaultErrorHandler defaultFatalMessager defaultFlushOut
     liftIO $ putStrLn "Finding Module"
     mod <- findModule mod_nm Nothing
     liftIO $ putStrLn "Getting Module Info"
-    Just mod_info <- getModuleInfo mod
+    mod_info <- fromJust <$> getModuleInfo mod
 
     liftIO $ putStrLn "Showing Details For Module"
     showTargetAnns (ModuleTarget mod)
diff --git a/testsuite/tests/deSugar/should_run/dsrun010.hs b/testsuite/tests/deSugar/should_run/dsrun010.hs
index 4b8bf4e1bc..5657fb7526 100644
--- a/testsuite/tests/deSugar/should_run/dsrun010.hs
+++ b/testsuite/tests/deSugar/should_run/dsrun010.hs
@@ -2,6 +2,8 @@
 -- is reflected by calling the monadic 'fail', not by a
 -- runtime exception
 
+{-# LANGUAGE NoMonadFailDesugaring #-}
+
 import Control.Monad
 import Data.Maybe
 
diff --git a/testsuite/tests/determinism/determ017/A.hs b/testsuite/tests/determinism/determ017/A.hs
index 2540be4b29..5e3c3d0809 100644
--- a/testsuite/tests/determinism/determ017/A.hs
+++ b/testsuite/tests/determinism/determ017/A.hs
@@ -20,7 +20,7 @@
 -- | Module "Trampoline" defines the pipe computations and their basic building blocks.
 
 {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses,
-             TypeFamilies, KindSignatures, FlexibleContexts,
+             TypeFamilies, KindSignatures, FlexibleContexts, NoMonadFailDesugaring,
              FlexibleInstances, OverlappingInstances, UndecidableInstances
  #-}
 
diff --git a/testsuite/tests/monadfail/MonadFailWarnings.hs b/testsuite/tests/monadfail/MonadFailWarnings.hs
index a1d3729222..f540201c53 100644
--- a/testsuite/tests/monadfail/MonadFailWarnings.hs
+++ b/testsuite/tests/monadfail/MonadFailWarnings.hs
@@ -1,7 +1,7 @@
 -- Test purpose:
 -- Ensure that MonadFail warnings are issued correctly if the warning flag
 -- is enabled
-
+{-# LANGUAGE NoMonadFailDesugaring #-}
 {-# OPTIONS_GHC -Wmissing-monadfail-instances #-}
 
 module MonadFailWarnings where
diff --git a/testsuite/tests/monadfail/MonadFailWarningsDisabled.hs b/testsuite/tests/monadfail/MonadFailWarningsDisabled.hs
index d3df107a4a..c6fd34a67e 100644
--- a/testsuite/tests/monadfail/MonadFailWarningsDisabled.hs
+++ b/testsuite/tests/monadfail/MonadFailWarningsDisabled.hs
@@ -2,6 +2,11 @@
 -- Make sure that not enabling MonadFail warnings makes code compile just
 -- as it did in < 8.0
 
+-- NOTE: starting w/ GHC 8.6 sugaring is turned on by default; so we have
+--       to disable to keep supporting this test-case
+--
+{-# LANGUAGE NoMonadFailDesugaring #-}
+
 module MonadFailWarnings where
 
 import Control.Monad.Fail
diff --git a/testsuite/tests/rebindable/rebindable1.hs b/testsuite/tests/rebindable/rebindable1.hs
index 8fcc5d2697..fcbe52fbc1 100644
--- a/testsuite/tests/rebindable/rebindable1.hs
+++ b/testsuite/tests/rebindable/rebindable1.hs
@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -Wno-missing-monadfail-instances #-}
-{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-}
+{-# LANGUAGE RebindableSyntax, NPlusKPatterns, NoMonadFailDesugaring #-}
 
 module RebindableCase1 where
         {
diff --git a/testsuite/tests/simplCore/should_run/T3591.hs b/testsuite/tests/simplCore/should_run/T3591.hs
index 6ec51a14d5..27bb52432e 100644
--- a/testsuite/tests/simplCore/should_run/T3591.hs
+++ b/testsuite/tests/simplCore/should_run/T3591.hs
@@ -20,7 +20,7 @@
 -- | Module "Trampoline" defines the pipe computations and their basic building blocks.
 
 {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses,
-             TypeFamilies, KindSignatures, FlexibleContexts,
+             TypeFamilies, KindSignatures, FlexibleContexts, NoMonadFailDesugaring,
              FlexibleInstances, OverlappingInstances, UndecidableInstances
  #-}
 
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
index 707e153a8d..a26c565b03 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
@@ -1,6 +1,6 @@
 -- Test purpose:
 -- Ensure that not using -Wcompat does not enable its warnings
-
+{-# LANGUAGE NoMonadFailDesugaring #-}
 -- {-# OPTIONS_GHC -Wcompat #-}
 -- {-# OPTIONS_GHC -Wno-compat #-}
 
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
index 777c11cd70..33c26ccbc1 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
@@ -1,6 +1,6 @@
 -- Test purpose:
 -- Ensure that using -Wno-compat does not switch on warnings
-
+{-# LANGUAGE NoMonadFailDesugaring #-}
 -- {-# OPTIONS_GHC -Wcompat #-}
 {-# OPTIONS_GHC -Wno-compat #-}
 
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
index 6d67ed039f..7d9e7de4fa 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
@@ -1,6 +1,6 @@
 -- Test purpose:
 -- Ensure that -Wcompat switches on the right warnings
-
+{-# LANGUAGE NoMonadFailDesugaring #-}
 {-# OPTIONS_GHC -Wcompat #-}
 -- {-# OPTIONS_GHC -Wno-compat #-}
 
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
index e6a4aa3efb..81df7577e2 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
@@ -1,6 +1,6 @@
 -- Test purpose:
 -- Ensure that -Wno-compat disables a previously set -Wcompat
-
+{-# LANGUAGE NoMonadFailDesugaring #-}
 {-# OPTIONS_GHC -Wcompat #-}
 {-# OPTIONS_GHC -Wno-compat #-}