Canonicalise `MonadPlus` instances

This refactoring exploits the fact that since AMP, in most cases,
`instance MonadPlus` can be automatically derived from the respective
`Alternative` instance.  This is because `MonadPlus`'s default method
implementations are fully defined in terms of `Alternative(empty, (<>))`.

10 files changed, 32 insertions, 56 deletions

diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 2a174b13fc..13e271bc66 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -656,13 +656,11 @@ instance MonadFail.MonadFail RuleM where
 #endif
 
 instance Alternative RuleM where
-    empty = mzero
-    (<|>) = mplus
+  empty = RuleM $ \_ _ _ -> Nothing
+  RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
+    f1 dflags iu args <|> f2 dflags iu args
 
-instance MonadPlus RuleM where
-  mzero = RuleM $ \_ _ _ -> Nothing
-  mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args ->
-    f1 dflags iu args `mplus` f2 dflags iu args
+instance MonadPlus RuleM
 
 instance HasDynFlags RuleM where
     getDynFlags = RuleM $ \dflags _ _ -> Just dflags
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 4958474a9d..9f80a17869 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -4,7 +4,7 @@
 \section[CoreMonad]{The core pipeline monad}
 -}
 
-{-# LANGUAGE CPP, UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
 
 module CoreMonad (
     -- * Configuration of the core-to-core passes
@@ -570,15 +570,11 @@ instance Applicative CoreM where
     (<*>) = ap
     m *> k = m >>= \_ -> k
 
-instance MonadPlus IO => Alternative CoreM where
-    empty = mzero
-    (<|>) = mplus
+instance Alternative CoreM where
+    empty   = CoreM (const Control.Applicative.empty)
+    m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs)
 
--- For use if the user has imported Control.Monad.Error from MTL
--- Requires UndecidableInstances
-instance MonadPlus IO => MonadPlus CoreM where
-    mzero = CoreM (const mzero)
-    m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
+instance MonadPlus CoreM
 
 instance MonadUnique CoreM where
     getUniqueSupplyM = do
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index c4c95bfd73..f5f0f084d3 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -390,9 +390,7 @@ instance Alternative UnifyResultM where
   _                 <|> b@(MaybeApart {}) = b
   SurelyApart       <|> SurelyApart       = SurelyApart
 
-instance MonadPlus UnifyResultM where
-  mzero = Control.Applicative.empty
-  mplus = (<|>)
+instance MonadPlus UnifyResultM
 
 -- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose
 -- domain elements all respond 'BindMe' to @bind_tv@) such that
@@ -912,16 +910,14 @@ instance Monad UM where
                   do { (state', v) <- unUM m env state
                      ; unUM (k v) env state' })
 
+-- need this instance because of a use of 'guard' above
 instance Alternative UM where
-  empty     = UM (\_ _ -> mzero)
+  empty     = UM (\_ _ -> Control.Applicative.empty)
   m1 <|> m2 = UM (\env state ->
                   unUM m1 env state <|>
                   unUM m2 env state)
 
-  -- need this instance because of a use of 'guard' above
-instance MonadPlus UM where
-  mzero = Control.Applicative.empty
-  mplus = (<|>)
+instance MonadPlus UM
 
 #if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail UM where
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 4470420a64..6c081ea3d0 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, UndecidableInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE CPP #-}
 
 --
@@ -177,15 +177,11 @@ uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env))
 -- Alternative/MonadPlus
 ----------------------------------------------------------------------
 
-instance MonadPlus IO => Alternative (IOEnv env) where
-      empty = mzero
-      (<|>) = mplus
+instance Alternative (IOEnv env) where
+    empty   = IOEnv (const empty)
+    m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env)
 
--- For use if the user has imported Control.Monad.Error from MTL
--- Requires UndecidableInstances
-instance MonadPlus IO => MonadPlus (IOEnv env) where
-    mzero = IOEnv (const mzero)
-    m `mplus` n = IOEnv (\env -> unIOEnv m env `mplus` unIOEnv n env)
+instance MonadPlus (IOEnv env)
 
 ----------------------------------------------------------------------
 -- Accessing input/output
diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs
index 36eb574e78..af4f0253db 100644
--- a/compiler/utils/MonadUtils.hs
+++ b/compiler/utils/MonadUtils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 
 -- | Utilities related to Monad and Applicative classes
 --   Mostly for backwards compatability.
@@ -30,11 +31,12 @@ module MonadUtils
 
 import Maybes
 
-import Control.Applicative
 import Control.Monad
 import Control.Monad.Fix
 import Control.Monad.IO.Class
-import Prelude -- avoid redundant import warning due to AMP
+#if __GLASGOW_HASKELL__ < 800
+import Control.Monad.Trans.Error () -- for orphan `instance MonadPlus IO`
+#endif
 
 -------------------------------------------------------------------------------
 -- Lift combinators
diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs
index 3417f30cc1..9fc2ee5c90 100644
--- a/libraries/base/Control/Arrow.hs
+++ b/libraries/base/Control/Arrow.hs
@@ -321,9 +321,7 @@ instance ArrowPlus a => Alternative (ArrowMonad a) where
    empty = ArrowMonad zeroArrow
    ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
 
-instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where
-   mzero = ArrowMonad zeroArrow
-   ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y)
+instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a)
 
 -- | Any instance of 'ArrowApply' can be made into an instance of
 --   'ArrowChoice' by defining 'left' = 'leftApp'.
diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs
index 6fa0cd85d6..518e215661 100644
--- a/libraries/base/Data/Semigroup.hs
+++ b/libraries/base/Data/Semigroup.hs
@@ -592,9 +592,7 @@ instance Alternative Option where
   Option Nothing <|> b = b
   a <|> _ = a
 
-instance MonadPlus Option where
-  mzero = Option Nothing
-  mplus = (<|>)
+instance MonadPlus Option
 
 instance MonadFix Option where
   mfix f = Option (mfix (getOption . f))
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index e1d894a8c1..2a5164b798 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -659,9 +659,7 @@ instance Alternative STM where
   empty = retry
   (<|>) = orElse
 
-instance MonadPlus STM where
-  mzero = empty
-  mplus = (<|>)
+instance MonadPlus STM
 
 -- | Unsafely performs IO in the STM monad.  Beware: this is a highly
 -- dangerous thing to do.
diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs
index 6c340e4597..8b84acf24e 100644
--- a/libraries/base/Text/ParserCombinators/ReadP.hs
+++ b/libraries/base/Text/ParserCombinators/ReadP.hs
@@ -108,9 +108,7 @@ instance Applicative P where
   pure x = Result x Fail
   (<*>) = ap
 
-instance MonadPlus P where
-  mzero = empty
-  mplus = (<|>)
+instance MonadPlus P
 
 instance Monad P where
   (Get f)      >>= k = Get (\c -> f c >>= k)
@@ -175,12 +173,10 @@ instance MonadFail ReadP where
   fail _    = R (\_ -> Fail)
 
 instance Alternative ReadP where
-    empty = mzero
-    (<|>) = mplus
+  empty = pfail
+  (<|>) = (+++)
 
-instance MonadPlus ReadP where
-  mzero = pfail
-  mplus = (+++)
+instance MonadPlus ReadP
 
 -- ---------------------------------------------------------------------------
 -- Operations over P
diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs
index 136b8aed00..2a9c1d0fe8 100644
--- a/libraries/base/Text/ParserCombinators/ReadPrec.hs
+++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs
@@ -87,13 +87,11 @@ instance Monad ReadPrec where
 instance MonadFail.MonadFail ReadPrec where
   fail s    = P (\_ -> fail s)
 
-instance MonadPlus ReadPrec where
-  mzero = pfail
-  mplus = (+++)
+instance MonadPlus ReadPrec
 
 instance Alternative ReadPrec where
-    empty = mzero
-    (<|>) = mplus
+  empty = pfail
+  (<|>) = (+++)
 
 -- precedences
 type Prec = Int