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

12 files changed, 484 insertions, 25 deletions

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;