Make Monad/Applicative instances MRP-friendly

This patch refactors pure/(*>) and return/(>>) in MRP-friendly way, i.e.
such that the explicit definitions for `return` and `(>>)` match the
MRP-style default-implementation, i.e.

  return = pure

and

  (>>) = (*>)

This way, e.g. all `return = pure` definitions can easily be grepped and
removed in GHC 8.1;

Test Plan: Harbormaster

Reviewers: goldfire, alanz, bgamari, quchen, austin

Reviewed By: quchen, austin

Subscribers: thomie

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

5 files changed, 29 insertions, 17 deletions

diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs
index 850393e359..8168992e00 100644
--- a/compiler/utils/Exception.hs
+++ b/compiler/utils/Exception.hs
@@ -6,6 +6,7 @@ module Exception
     )
     where
 
+import Control.Applicative as A
 import Control.Exception
 import Control.Monad.IO.Class
 
@@ -28,7 +29,7 @@ tryIO = try
 -- implementations of 'gbracket' and 'gfinally' use 'gmask'
 -- thus rarely require overriding.
 --
-class MonadIO m => ExceptionMonad m where
+class (A.Applicative m, MonadIO m) => ExceptionMonad m where
 
   -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
   -- exception handling monad instead of just 'IO'.
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index fae3b9634f..31ac2b3731 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -58,13 +58,14 @@ unIOEnv (IOEnv m) = m
 
 instance Monad (IOEnv m) where
     (>>=)  = thenM
-    (>>)   = thenM_
-    return = returnM
+    (>>)   = (*>)
+    return = pure
     fail _ = failM -- Ignore the string
 
 instance Applicative (IOEnv m) where
     pure = returnM
     IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
+    (*>) = thenM_
 
 instance Functor (IOEnv m) where
     fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index 84e2d97d56..56b6dab5d9 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -68,32 +68,42 @@ instance Functor m => Functor (MaybeT m) where
 
 #if __GLASGOW_HASKELL__ < 710
 -- Pre-AMP change
-instance (Monad m, Functor m) => Applicative (MaybeT m) where
+instance (Monad m, Applicative m) => Applicative (MaybeT m) where
 #else
 instance (Monad m) => Applicative (MaybeT m) where
 #endif
-  pure  = return
+  pure = MaybeT . pure . Just
   (<*>) = ap
 
-instance Monad m => Monad (MaybeT m) where
-  return = MaybeT . return . Just
-  x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f)
-  fail _ = MaybeT $ return Nothing
+#if __GLASGOW_HASKELL__ < 710
+-- Pre-AMP change
+instance (Monad m, Applicative m) => Monad (MaybeT m) where
+#else
+instance (Monad m) => Monad (MaybeT m) where
+#endif
+  return = pure
+  x >>= f = MaybeT $ runMaybeT x >>= maybe (pure Nothing) (runMaybeT . f)
+  fail _ = MaybeT $ pure Nothing
 
 #if __GLASGOW_HASKELL__ < 710
 -- Pre-AMP change
-instance (Monad m, Functor m) => Alternative (MaybeT m) where
+instance (Monad m, Applicative m) => Alternative (MaybeT m) where
 #else
 instance (Monad m) => Alternative (MaybeT m) where
 #endif
   empty = mzero
   (<|>) = mplus
 
+#if __GLASGOW_HASKELL__ < 710
+-- Pre-AMP change
+instance (Monad m, Applicative m) => MonadPlus (MaybeT m) where
+#else
 instance Monad m => MonadPlus (MaybeT m) where
-  mzero       = MaybeT $ return Nothing
+#endif
+  mzero       = MaybeT $ pure Nothing
   p `mplus` q = MaybeT $ do ma <- runMaybeT p
                             case ma of
-                              Just a  -> return (Just a)
+                              Just a  -> pure (Just a)
                               Nothing -> runMaybeT q
 
 liftMaybeT :: Monad m => m a -> MaybeT m a
@@ -113,11 +123,11 @@ instance Functor (MaybeErr err) where
   fmap = liftM
 
 instance Applicative (MaybeErr err) where
-  pure  = return
+  pure  = Succeeded
   (<*>) = ap
 
 instance Monad (MaybeErr err) where
-  return v = Succeeded v
+  return = pure
   Succeeded v >>= k = k v
   Failed e    >>= _ = Failed e
 
diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
index 7346841613..a1903cee76 100644
--- a/compiler/utils/State.hs
+++ b/compiler/utils/State.hs
@@ -19,7 +19,7 @@ instance Applicative (State s) where
                                            (# x, s'' #) -> (# f x, s'' #)
 
 instance Monad (State s) where
-    return x = State $ \s -> (# x, s #)
+    return = pure
     m >>= n  = State $ \s -> case runState' m s of
                              (# r, s' #) -> runState' (n r) s'
 
diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs
index edb0b0c558..fcef97b654 100644
--- a/compiler/utils/Stream.hs
+++ b/compiler/utils/Stream.hs
@@ -46,11 +46,11 @@ instance Monad f => Functor (Stream f a) where
   fmap = liftM
 
 instance Monad m => Applicative (Stream m a) where
-  pure  = return
+  pure a = Stream (return (Left a))
   (<*>) = ap
 
 instance Monad m => Monad (Stream m a) where
-  return a = Stream (return (Left a))
+  return = pure
 
   Stream m >>= k = Stream $ do
                 r <- m