Simplify the MonadFail code

Simplify and tidy up the MonadFail code.
See TcMatches.tcMonadFailOp

Less, code; and more robust.

This incidentally fixes a bug; see the change
to MonadFailErrors.stderr

2 files changed, 94 insertions, 132 deletions

diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index cd1cddd786..3888f89233 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -40,7 +40,6 @@ import SrcLoc
 import FastString
 import DynFlags
 import PrelNames (monadFailClassName)
-import Type
 import Inst
 
 -- Create chunkified tuple tybes for monad comprehensions
@@ -523,19 +522,13 @@ 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
-        ; fail_op' <- if isIrrefutableHsPat pat
-            then return noSyntaxExpr
-            else tcSyntaxOp (MCompPatOrigin pat)
-                            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
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
 
         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
@@ -775,19 +768,13 @@ 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
-        ; fail_op' <- if isIrrefutableHsPat pat
-            then return noSyntaxExpr
-            else tcSyntaxOp (DoPatOrigin pat)
-                            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
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
 
         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
@@ -887,24 +874,44 @@ the expected/inferred stuff is back to front (see Trac #3613).
 -- 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 ()
+tcMonadFailOp :: CtOrigin
+              -> LPat TcId
+              -> HsExpr Name         -- The fail op
+              -> TcType              -- Type of the whole do-expression
+              -> TcRn (HsExpr TcId)  -- Typechecked fail op
+-- Get a 'fail' operator expression, to use if the pattern
+-- match fails. If the pattern is irrefutatable, just return
+-- noSyntaxExpr; it won't be used
+tcMonadFailOp orig pat fail_op res_ty
+  | isIrrefutableHsPat pat
+  = return noSyntaxExpr
+
+  | otherwise
+  = do { -- Issue MonadFail warnings
+         rebindableSyntax <- xoptM Opt_RebindableSyntax
+       ; desugarFlag      <- xoptM Opt_MonadFailDesugaring
+       ; missingWarning   <- woptM Opt_WarnMissingMonadFailInstance
+       ; if | rebindableSyntax && (desugarFlag || missingWarning)
+              -> warnRebindableClash pat
+            | not desugarFlag && missingWarning
+              -> emitMonadFailConstraint pat res_ty
+            | otherwise
+              -> return ()
+
+        -- Get the fail op itself
+        ; tcSyntaxOp orig fail_op (mkFunTy stringTy res_ty) }
+
+emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()
+emitMonadFailConstraint pat res_ty
+  = do { -- We expect res_ty to be of form (monad_ty arg_ty)
+         (_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty
+
+         -- Emit (MonadFail m), but ignore the evidence; it's
+         -- just there to generate a warning
+       ; monadFailClass <- tcLookupClass monadFailClassName
+       ; _ <- emitWanted (FailablePattern pat)
+                         (mkClassPred monadFailClass [monad_ty])
+       ; return () }
 
 warnRebindableClash :: LPat TcId -> TcRn ()
 warnRebindableClash pattern = addWarnAt (getLoc pattern)
@@ -915,25 +922,6 @@ warnRebindableClash pattern = addWarnAt (getLoc pattern)
              $$
              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/testsuite/tests/monadfail/MonadFailErrors.stderr b/testsuite/tests/monadfail/MonadFailErrors.stderr
index 17807a4be0..8a478eecf3 100644
--- a/testsuite/tests/monadfail/MonadFailErrors.stderr
+++ b/testsuite/tests/monadfail/MonadFailErrors.stderr
@@ -1,86 +1,60 @@
 
 MonadFailErrors.hs:16:5: error:
-    Could not deduce (MonadFail m)
-      arising from a do statement
-                   with the failable pattern ‘Just x’
-    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 }
+    • Could not deduce (MonadFail m)
+        arising from a do statement
+        with the failable pattern ‘Just x’
+      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
-                   with the failable pattern ‘Just x’
-    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 }
+    • No instance for (MonadFail Identity)
+        arising from a do statement
+        with the failable pattern ‘Just x’
+    • 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
-                   with the failable pattern ‘Just x’
-    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 }
+    • No instance for (MonadFail (ST s))
+        arising from a do statement
+        with the failable pattern ‘Just x’
+    • 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
-                   with the failable pattern ‘Just x’
-    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
-                   with the failable pattern ‘Newtype x’
-    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
-                   with the failable pattern ‘Data x’
-    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 }
+    • No instance for (MonadFail ((->) r))
+        arising from a do statement
+        with the failable pattern ‘Just x’
+    • 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 }