Canonicalise MonoidFail instances in GHC

IOW, code compiles -Wnoncanonical-monoidfail-instances clean now

This is easy now since we require GHC 8.0/base-4.9 or later
for bootstrapping.

Note that we can easily enable `MonadFail` via

  default-extensions: MonadFailDesugaring

in compiler/ghc.cabal.in

which currently would point out that NatM doesn't have
a proper `fail` method, even though failable patterns
are made use of:

  compiler/nativeGen/SPARC/CodeGen.hs:425:25: error:
    * No instance for (Control.Monad.Fail.MonadFail NatM)
        arising from a do statement
        with the failable pattern ‘(dyn_c, [dyn_r])’

11 files changed, 15 insertions, 10 deletions

diff --git a/compiler/cmm/CmmMonad.hs b/compiler/cmm/CmmMonad.hs
index c035577473..e225d7dd4f 100644
--- a/compiler/cmm/CmmMonad.hs
+++ b/compiler/cmm/CmmMonad.hs
@@ -29,7 +29,7 @@ instance Applicative PD where
 
 instance Monad PD where
   (>>=) = thenPD
-  fail = failPD
+  fail = MonadFail.fail
 
 instance MonadFail.MonadFail PD where
   fail = failPD
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 92c14bc871..6195e675cb 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1948,7 +1948,7 @@ instance Applicative LintM where
       (<*>) = ap
 
 instance Monad LintM where
-  fail err = failWithL (text err)
+  fail = MonadFail.fail
   m >>= k  = LintM (\ env errs ->
                        let (res, errs') = unLintM m env errs in
                          case res of
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 30592d17e0..247d2ee055 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -76,6 +76,7 @@ Library
     GHC-Options: -Wall
                  -Wno-name-shadowing
                  -Wnoncanonical-monad-instances
+                 -Wnoncanonical-monadfail-instances
                  -Wnoncanonical-monoid-instances
 
     if flag(ghci)
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index c5332fbe2f..5d3d65d035 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -77,7 +77,7 @@ module Lexer (
 
 -- base
 import Control.Monad
-import Control.Monad.Fail
+import Control.Monad.Fail as MonadFail
 import Data.Bits
 import Data.Char
 import Data.List
@@ -1890,7 +1890,7 @@ instance Applicative P where
 
 instance Monad P where
   (>>=) = thenP
-  fail = failP
+  fail = MonadFail.fail
 
 instance MonadFail P where
   fail = failP
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 13f4f12736..d2b8d875b2 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -647,7 +647,7 @@ instance Monad RuleM where
   RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
     Nothing -> Nothing
     Just r -> runRuleM (g r) dflags iu e
-  fail _ = mzero
+  fail = MonadFail.fail
 
 instance MonadFail.MonadFail RuleM where
     fail _ = mzero
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index a0844b7dfa..dfbb16a9cb 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -2285,7 +2285,7 @@ instance Monad SpecM where
                                case f y of
                                    SpecM z ->
                                        z
-    fail str = SpecM $ fail str
+    fail = MonadFail.fail
 
 instance MonadFail.MonadFail SpecM where
     fail str = SpecM $ fail str
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 0eff63d8bd..0a76d23ad3 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -3513,7 +3513,7 @@ instance Applicative TcPluginM where
   (<*>) = ap
 
 instance Monad TcPluginM where
-  fail x   = TcPluginM (const $ fail x)
+  fail = MonadFail.fail
   TcPluginM m >>= k =
     TcPluginM (\ ev -> do a <- m ev
                           runTcPluginM (k a) ev)
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index c168c08a0f..932237c6c3 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -2291,7 +2291,7 @@ instance Applicative TcS where
   (<*>) = ap
 
 instance Monad TcS where
-  fail err  = TcS (\_ -> fail err)
+  fail = MonadFail.fail
   m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
 
 instance MonadFail.MonadFail TcS where
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index 80cccb3c3c..c5b7e66e46 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -1034,7 +1034,7 @@ instance Applicative UM where
       (<*>)  = ap
 
 instance Monad UM where
-  fail _   = UM (\_ -> SurelyApart) -- failed pattern match
+  fail     = MonadFail.fail
   m >>= k  = UM (\state ->
                   do { (state', v) <- unUM m state
                      ; unUM (k v) state' })
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 5a7ccd9972..6fc5f9dc67 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -56,7 +56,7 @@ unIOEnv (IOEnv m) = m
 instance Monad (IOEnv m) where
     (>>=)  = thenM
     (>>)   = (*>)
-    fail _ = failM -- Ignore the string
+    fail   = MonadFail.fail
 
 instance MonadFail.MonadFail (IOEnv m) where
     fail _ = failM -- Ignore the string
diff --git a/compiler/utils/ListT.hs b/compiler/utils/ListT.hs
index 2b81db1ed4..7dc1aa3eaf 100644
--- a/compiler/utils/ListT.hs
+++ b/compiler/utils/ListT.hs
@@ -32,6 +32,7 @@ module ListT (
 import Control.Applicative
 
 import Control.Monad
+import Control.Monad.Fail as MonadFail
 
 -------------------------------------------------------------------------
 -- | A monad transformer for performing backtracking computations
@@ -64,6 +65,9 @@ instance Alternative (ListT f) where
 
 instance Monad (ListT m) where
     m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk
+    fail = MonadFail.fail
+
+instance MonadFail (ListT m) where
     fail _ = ListT $ \_ fk -> fk
 
 instance MonadPlus (ListT m) where