Rip out remainder of MonadFailDesugaring

4 files changed, 13 insertions, 69 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d29fa4a9f9..3b02b864aa 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -824,7 +824,6 @@ data WarningFlag =
    | Opt_WarnDeferredTypeErrors
    | Opt_WarnDeferredOutOfScopeVariables
    | Opt_WarnNonCanonicalMonadInstances   -- since 8.0
-   | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0
    | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0
    | Opt_WarnMissingPatternSynonymSignatures -- since 8.0
    | Opt_WarnUnrecognisedWarningFlags     -- since 8.0
@@ -2252,7 +2251,6 @@ languageExtensions (Just Haskell98)
     = [LangExt.ImplicitPrelude,
        -- See Note [When is StarIsType enabled]
        LangExt.StarIsType,
-       LangExt.MonadFailDesugaring,
        LangExt.MonomorphismRestriction,
        LangExt.NPlusKPatterns,
        LangExt.DatatypeContexts,
@@ -2269,7 +2267,6 @@ languageExtensions (Just Haskell2010)
     = [LangExt.ImplicitPrelude,
        -- See Note [When is StarIsType enabled]
        LangExt.StarIsType,
-       LangExt.MonadFailDesugaring,
        LangExt.MonomorphismRestriction,
        LangExt.DatatypeContexts,
        LangExt.TraditionalRecordSyntax,
@@ -4016,8 +4013,6 @@ wWarningFlagsDeps = [
   flagSpec "name-shadowing"              Opt_WarnNameShadowing,
   flagSpec "noncanonical-monad-instances"
                                          Opt_WarnNonCanonicalMonadInstances,
-  flagSpec "noncanonical-monadfail-instances"
-                                         Opt_WarnNonCanonicalMonadFailInstances,
   flagSpec "noncanonical-monoid-instances"
                                          Opt_WarnNonCanonicalMonoidInstances,
   flagSpec "orphans"                     Opt_WarnOrphans,
@@ -4401,7 +4396,8 @@ xFlagsDeps = [
   flagSpec "LiberalTypeSynonyms"              LangExt.LiberalTypeSynonyms,
   flagSpec "MagicHash"                        LangExt.MagicHash,
   flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,
-  flagSpec "MonadFailDesugaring"              LangExt.MonadFailDesugaring,
+  depFlagSpec "MonadFailDesugaring"           LangExt.MonadFailDesugaring
+    "MonadFailDesugaring is now the default behavior",
   flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,
   depFlagSpecCond "MonoPatBinds"              LangExt.MonoPatBinds
     id
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 600eb2ba4d..4a104c63a9 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -314,7 +314,7 @@ basicKnownKeyNames
         returnMName, joinMName,
 
         -- MonadFail
-        monadFailClassName, failMName, failMName_preMFP,
+        monadFailClassName, failMName,
 
         -- MonadFix
         monadFixClassName, mfixName,
@@ -669,13 +669,12 @@ map_RDR, append_RDR :: RdrName
 map_RDR                 = nameRdrName mapName
 append_RDR              = nameRdrName appendName
 
-foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP,
-  failM_RDR :: RdrName
+foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, 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
@@ -1018,12 +1017,11 @@ functorClassName  = clsQual gHC_BASE    (fsLit "Functor") functorClassKey
 fmapName          = varQual gHC_BASE    (fsLit "fmap")    fmapClassOpKey
 
 -- Class Monad
-monadClassName, thenMName, bindMName, returnMName, failMName_preMFP :: Name
+monadClassName, thenMName, bindMName, returnMName :: 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_preMFP   = varQual gHC_BASE (fsLit "fail")   failMClassOpKey_preMFP
 
 -- Class MonadFail
 monadFailClassName, failMName :: Name
@@ -2253,8 +2251,7 @@ unboundKey                    = mkPreludeMiscIdUnique 158
 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
     enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
     enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
-    failMClassOpKey_preMFP, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
-    fmapClassOpKey
+    bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey
     :: Unique
 fromIntegerClassOpKey         = mkPreludeMiscIdUnique 160
 minusClassOpKey               = mkPreludeMiscIdUnique 161
@@ -2266,7 +2263,6 @@ enumFromThenToClassOpKey      = mkPreludeMiscIdUnique 166
 eqClassOpKey                  = mkPreludeMiscIdUnique 167
 geClassOpKey                  = mkPreludeMiscIdUnique 168
 negateClassOpKey              = mkPreludeMiscIdUnique 169
-failMClassOpKey_preMFP        = mkPreludeMiscIdUnique 170
 bindMClassOpKey               = mkPreludeMiscIdUnique 171 -- (>>=)
 thenMClassOpKey               = mkPreludeMiscIdUnique 172 -- (>>)
 fmapClassOpKey                = mkPreludeMiscIdUnique 173
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index bed53ece35..9d19e1a01d 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -2100,11 +2100,6 @@ badIpBinds what binds
 
 ---------
 
-lookupSyntaxMonadFailOpName :: Bool -> RnM (SyntaxExpr GhcRn, FreeVars)
-lookupSyntaxMonadFailOpName monadFailEnabled
-  | monadFailEnabled = lookupSyntaxName failMName
-  | otherwise        = lookupSyntaxName failMName_preMFP
-
 monadFailOp :: LPat GhcPs
             -> HsStmtContext Name
             -> RnM (SyntaxExpr GhcRn, FreeVars)
@@ -2146,14 +2141,14 @@ So, in this case, we synthesize the function
 -}
 getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
 getMonadFailOp
- = do { xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
-      ; xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
+ = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
       ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
-      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings xMonadFailEnabled }
+      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+      }
   where
-    reallyGetMonadFailOp rebindableSyntax overloadedStrings monadFailEnabled
+    reallyGetMonadFailOp rebindableSyntax overloadedStrings
       | rebindableSyntax && overloadedStrings = do
-        (failExpr, failFvs) <- lookupSyntaxMonadFailOpName monadFailEnabled
+        (failExpr, failFvs) <- lookupSyntaxName failMName
         (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName
         let arg_lit = fsLit "arg"
             arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit
@@ -2167,4 +2162,4 @@ getMonadFailOp
         let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
               mkSyntaxExpr failAfterFromStringExpr
         return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
-      | otherwise = lookupSyntaxMonadFailOpName monadFailEnabled
+      | otherwise = lookupSyntaxName failMName
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 5155f3ab84..71616264dd 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -43,7 +43,6 @@ import Module
 import HscTypes         ( Warnings(..), plusWarns )
 import PrelNames        ( applicativeClassName, pureAName, thenAName
                         , monadClassName, returnMName, thenMName
-                        , monadFailClassName, failMName, failMName_preMFP
                         , semigroupClassName, sappendName
                         , monoidClassName, mappendName
                         )
@@ -457,9 +456,6 @@ checkCanonicalInstances cls poly_ty mbinds = do
     whenWOptM Opt_WarnNonCanonicalMonadInstances
         checkCanonicalMonadInstances
 
-    whenWOptM Opt_WarnNonCanonicalMonadFailInstances
-        checkCanonicalMonadFailInstances
-
     whenWOptM Opt_WarnNonCanonicalMonoidInstances
         checkCanonicalMonoidInstances
 
@@ -510,45 +506,6 @@ checkCanonicalInstances cls poly_ty mbinds = do
 
       | otherwise = return ()
 
-    -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance
-    -- declarations. Specifically, the following conditions are verified:
-    --
-    -- In 'Monad' instances declarations:
-    --
-    --  * If 'fail' is overridden it must be canonical
-    --    (i.e. @fail = Control.Monad.Fail.fail@)
-    --
-    -- In 'MonadFail' instance declarations:
-    --
-    --  * Warn if 'fail' is defined backwards
-    --    (i.e. @fail = Control.Monad.fail@).
-    --
-    checkCanonicalMonadFailInstances
-      | cls == monadFailClassName  = do
-          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
-              case mbind of
-                  FunBind { fun_id = (dL->L _ name)
-                          , fun_matches = mg }
-                      | name == failMName, isAliasMG mg == Just failMName_preMFP
-                      -> addWarnNonCanonicalMethod1
-                            Opt_WarnNonCanonicalMonadFailInstances "fail"
-                            "Control.Monad.fail"
-
-                  _ -> return ()
-
-      | cls == monadClassName  = do
-          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
-              case mbind of
-                  FunBind { fun_id      = (dL->L _ name)
-                          , fun_matches = mg }
-                      | name == failMName_preMFP, isAliasMG mg /= Just failMName
-                      -> addWarnNonCanonicalMethod2
-                            Opt_WarnNonCanonicalMonadFailInstances "fail"
-                            "Control.Monad.Fail.fail"
-                  _ -> return ()
-
-      | otherwise = return ()
-
     -- | Check whether Monoid(mappend) is defined in terms of
     -- Semigroup((<>)) (and not the other way round). Specifically,
     -- the following conditions are verified: