Fix AMP warnings.

Authored-by: David Luposchainsky <dluposchainsky@gmail.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

32 files changed, 283 insertions, 20 deletions

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 92a137b98b..970ce68149 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -21,6 +21,8 @@ import Outputable
 import DynFlags
 
 import Data.Maybe
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
 
 -- Things to check:
 --     - invariant on CmmBlock in CmmExpr (see comment there)
@@ -207,6 +209,13 @@ checkCond _ expr
 
 newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
 
+instance Functor CmmLint where
+      fmap = liftM
+
+instance Applicative CmmLint where
+      pure = return
+      (<*>) = ap
+
 instance Monad CmmLint where
   CmmLint m >>= k = CmmLint $ \dflags ->
                                 case m dflags of
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 149968d118..d45b103954 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -52,6 +52,8 @@ import Data.Map (Map)
 import Data.Word
 import System.IO
 import qualified Data.Map as Map
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
 
 import Data.Array.Unsafe ( castSTUArray )
 import Data.Array.ST hiding ( castSTUArray )
@@ -986,6 +988,13 @@ pprExternDecl _in_srt lbl
 type TEState = (UniqSet LocalReg, Map CLabel ())
 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
 
+instance Functor TE where
+      fmap = liftM
+
+instance Applicative TE where
+      pure = return
+      (<*>) = ap
+
 instance Monad TE where
    TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
    return a    = TE $ \s -> (a, s)
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index e710204222..df1733978f 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -48,6 +48,9 @@ import Module
 import UniqFM
 import Unique
 
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
+
 
 -- | The environment contains variable definitions or blockids.
 data Named
@@ -76,6 +79,13 @@ returnExtFC a   = EC $ \_ s -> return (s, a)
 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 
+instance Functor CmmParse where
+      fmap = liftM
+
+instance Applicative CmmParse where
+      pure = return
+      (<*>) = ap
+
 instance Monad CmmParse where
   (>>=) = thenExtFC
   return = returnExtFC
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 27d4fd6386..3d82e69402 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -74,6 +74,7 @@ import UniqSupply
 import FastString
 import Outputable
 
+import qualified Control.Applicative as A
 import Control.Monad
 import Data.List
 import Prelude hiding( sequence, succ )
@@ -113,6 +114,10 @@ newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
 instance Functor FCode where
   fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)
 
+instance A.Applicative FCode where
+      pure = return
+      (<*>) = ap
+
 instance Monad FCode where
         (>>=) = thenFC
         return = returnFC
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 1913e3ab93..ffddd78516 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -1025,6 +1025,13 @@ The same substitution also supports let-type, current expressed as
 Here we substitute 'ty' for 'a' in 'body', on the fly.
 -}
 
+instance Functor LintM where
+      fmap = liftM
+
+instance Applicative LintM where
+      pure = return
+      (<*>) = ap
+
 instance Monad LintM where
   return x = LintM (\ _   _     errs -> (Just x, errs))
   fail err = failWithL (text err)
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index a0776af218..bdb54d80d6 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -32,6 +32,7 @@ import DynFlags
 import FastString
 import Exception
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import qualified Data.ByteString as BS
 import Data.Char
@@ -55,6 +56,14 @@ data CoreState = CoreState {
                      cs_dflags :: DynFlags,
                      cs_module :: Module
                  }
+
+instance Functor CoreM where
+    fmap = liftM
+
+instance Applicative CoreM where
+    pure = return
+    (<*>) = ap
+
 instance Monad CoreM where
   (CoreM m) >>= f = CoreM (\ s -> case m s of
                                     (s',r) -> case f r of
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index bdcf9c9f78..889155c79e 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -964,6 +964,13 @@ data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTrans
         -- a combination of a state monad (TickTransState) and a writer
         -- monad (FreeVars).
 
+instance Functor TM where
+    fmap = liftM
+
+instance Applicative TM where
+    pure = return
+    (<*>) = ap
+
 instance Monad TM where
   return a = TM $ \ _env st -> (a,noFVs,st)
   (TM m) >>= k = TM $ \ env st ->
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index e3119a7842..dd8bbe4c83 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -35,6 +35,7 @@ import Outputable
 import Platform
 import Util
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Control.Monad.ST ( runST )
 import Control.Monad.Trans.Class
@@ -223,6 +224,13 @@ data Assembler a
   | Emit Word16 [Operand] (Assembler a)
   | NullAsm a
 
+instance Functor Assembler where
+    fmap = liftM
+
+instance Applicative Assembler where
+    pure = return
+    (<*>) = ap
+
 instance Monad Assembler where
   return = NullAsm
   NullAsm x >>= f = f x
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 9c9526de27..ee4895db95 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -55,6 +55,7 @@ import Data.List
 import Foreign
 import Foreign.C
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Data.Char
 
@@ -1586,6 +1587,13 @@ thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
 returnBc :: a -> BcM a
 returnBc result = BcM $ \st -> (return (st, result))
 
+instance Functor BcM where
+    fmap = liftM
+
+instance Applicative BcM where
+    pure = return
+    (<*>) = ap
+
 instance Monad BcM where
   (>>=) = thenBc
   (>>)  = thenBc_
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 383b641262..8a4f7d8783 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -32,7 +32,8 @@ import FastString
 import Outputable
 
 import qualified Data.ByteString as BS
-import Control.Monad( unless )
+import Control.Monad( unless, liftM, ap )
+import Control.Applicative (Applicative(..))
 
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
@@ -72,6 +73,13 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a }
 -- In particular, we want it on binding locations, so that variables bound in
 -- the spliced-in declarations get a location that at least relates to the splice point
 
+instance Functor CvtM where
+    fmap = liftM
+
+instance Applicative CvtM where
+    pure = return
+    (<*>) = ap
+
 instance Monad CvtM where
   return x       = CvtM $ \_   -> Right x
   (CvtM m) >>= k = CvtM $ \loc -> case m loc of
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index dda2c9e05b..6ae3c4252d 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -54,6 +54,9 @@ import UniqSupply
 import ErrUtils
 import qualified Stream
 
+import Control.Monad (ap)
+import Control.Applicative (Applicative(..))
+
 -- ----------------------------------------------------------------------------
 -- * Some Data Types
 --
@@ -209,13 +212,19 @@ type LlvmEnvMap = UniqFM LlvmType
 
 -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
 newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
+
+instance Functor LlvmM where
+    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+                                  return (f x, env')
+
+instance Applicative LlvmM where
+    pure = return
+    (<*>) = ap
+
 instance Monad LlvmM where
     return x = LlvmM $ \env -> return (x, env)
     m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env
                                   runLlvmM (f x) env'
-instance Functor LlvmM where
-    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
-                                  return (f x, env')
 
 instance HasDynFlags LlvmM where
     getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 252a376432..6681186246 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -30,6 +30,9 @@ import SrcLoc
 import Data.Function
 import Data.List
 
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
+
 
 --------------------------------------------------------
 --         The Flag and OptKind types
@@ -72,6 +75,13 @@ newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg
                               -> Errs -> Warns
                               -> m (Errs, Warns, a) }
 
+instance Monad m => Functor (EwM m) where
+    fmap = liftM
+
+instance Monad m => Applicative (EwM m) where
+    pure = return
+    (<*>) = ap
+
 instance Monad m => Monad (EwM m) where
     (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
                                       unEwM (k r) l e' w')
@@ -108,6 +118,13 @@ liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
 -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
 
+instance Functor (CmdLineP s) where
+    fmap = liftM
+
+instance Applicative (CmdLineP s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (CmdLineP s) where
     m >>= k = CmdLineP $ \s ->
                   let (a, s') = runCmdLine m s
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 7c5bc90647..a6567c8c39 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -669,6 +669,13 @@ newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
 evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
 evalP f env st = liftM snd $ unP f env st
 
+instance Functor CompPipeline where
+    fmap = liftM
+
+instance Applicative CompPipeline where
+    pure = return
+    (<*>) = ap
+
 instance Monad CompPipeline where
   return a = P $ \_env state -> return (state, a)
   P m >>= k = P $ \env state -> do (state',a) <- m env state
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index ad1b7c503a..774f5be488 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -194,6 +194,13 @@ knownKeyNames =              -- where templateHaskellNames are defined
 
 newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
 
+instance Functor Hsc where
+    fmap = liftM
+
+instance Applicative Hsc where
+    pure = return
+    (<*>) = ap
+
 instance Monad Hsc where
     return a    = Hsc $ \_ w -> return (a, w)
     Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
@@ -203,9 +210,6 @@ instance Monad Hsc where
 instance MonadIO Hsc where
     liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
 
-instance Functor Hsc where
-    fmap f m = m >>= \a -> return $ f a
-
 runHsc :: HscEnv -> Hsc a -> IO a
 runHsc hsc_env (Hsc hsc) = do
     (a, w) <- hsc hsc_env emptyBag
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index d6a3da13e6..9886fe394f 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -749,6 +749,13 @@ newtype DFFV a
       -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far
       -> ((VarSet,[Var]),a))  -- Output state
 
+instance Functor DFFV where
+    fmap = liftM
+
+instance Applicative DFFV where
+    pure = return
+    (<*>) = ap
+
 instance Monad DFFV where
   return a = DFFV $ \_ st -> (st, a)
   (DFFV m) >>= k = DFFV $ \env st ->
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 42eeb4ff13..cd00a8295d 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -80,6 +80,7 @@ import qualified Stream
 import Data.List
 import Data.Maybe
 import Control.Exception
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import System.IO
 
@@ -873,6 +874,13 @@ cmmToCmm dflags this_mod (CmmProc info lbl live graph)
 
 newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))
 
+instance Functor CmmOptM where
+    fmap = liftM
+
+instance Applicative CmmOptM where
+    pure = return
+    (<*>) = ap
+
 instance Monad CmmOptM where
   return x = CmmOptM $ \_ _ imports -> (# x, imports #)
   (CmmOptM f) >>= g =
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index fec6805b4e..3ee3af2ea9 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -41,6 +41,9 @@ import Unique           ( Unique )
 import DynFlags
 import Module
 
+import Control.Monad    ( liftM, ap )
+import Control.Applicative ( Applicative(..) )
+
 data NatM_State
         = NatM_State {
                 natm_us          :: UniqSupply,
@@ -65,6 +68,13 @@ initNat init_st m
         = case unNat m init_st of { (r,st) -> (r,st) }
 
 
+instance Functor NatM where
+      fmap = liftM
+
+instance Applicative NatM where
+      pure = return
+      (<*>) = ap
+
 instance Monad NatM where
   (>>=) = thenNat
   return = returnNat
diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
index a608a947e7..dc499c9c1f 100644
--- a/compiler/nativeGen/RegAlloc/Linear/State.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -40,13 +40,21 @@ import DynFlags
 import Unique
 import UniqSupply
 
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
+
 
 -- | The register allocator monad type.
 newtype RegM freeRegs a
         = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
 
+instance Functor (RegM freeRegs) where
+      fmap = liftM
+
+instance Applicative (RegM freeRegs) where
+      pure = return
+      (<*>) = ap
 
--- | The RegM Monad
 instance Monad (RegM freeRegs) where
   m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
   return a  =  RegM $ \s -> (# s, a #)
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 64a9f9b912..3b895d8125 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -49,6 +49,7 @@ import Platform
 import Util
 import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
 
+import Control.Applicative ( Applicative(..), Alternative(..) )
 import Control.Monad
 import Data.Bits as Bits
 import qualified Data.ByteString as BS
@@ -540,6 +541,13 @@ mkBasicRule op_name n_args rm
 newtype RuleM r = RuleM
   { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
 
+instance Functor RuleM where
+    fmap = liftM
+
+instance Applicative RuleM where
+    pure = return
+    (<*>) = ap
+
 instance Monad RuleM where
   return x = RuleM $ \_ _ _ -> Just x
   RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
@@ -547,6 +555,10 @@ instance Monad RuleM where
     Just r -> runRuleM (g r) dflags iu e
   fail _ = mzero
 
+instance Alternative RuleM where
+    empty = mzero
+    (<|>) = mplus
+
 instance MonadPlus RuleM where
   mzero = RuleM $ \_ _ _ -> Nothing
   mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args ->
diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs
index 5417ad491e..fdcf7447eb 100644
--- a/compiler/profiling/SCCfinal.lhs
+++ b/compiler/profiling/SCCfinal.lhs
@@ -36,6 +36,9 @@ import FastString
 import SrcLoc
 import Util
 
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
+
 
 stgMassageForProfiling
         :: DynFlags
@@ -220,6 +223,13 @@ newtype MassageM result
                  -> (CollectedCCs, result)
     }
 
+instance Functor MassageM where
+      fmap = liftM
+
+instance Applicative MassageM where
+      pure = return
+      (<*>) = ap
+
 instance Monad MassageM where
     return x = MassageM (\_ ccs -> (ccs, x))
     (>>=) = thenMM
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index e7cecf8f3f..9488f91ddd 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -44,7 +44,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
 
 import HsSyn            
 import TcRnMonad
-import TcHsSyn          ( hsOverLitName )
+import TcHsSyn             ( hsOverLitName )
 import RnEnv
 import RnTypes
 import DynFlags
@@ -54,14 +54,14 @@ import NameSet
 import RdrName
 import BasicTypes
 import Util
-import ListSetOps       ( removeDups )
+import ListSetOps          ( removeDups )
 import Outputable
 import SrcLoc
 import FastString
-import Literal          ( inCharRange )
-import TysWiredIn       ( nilDataCon )
-import DataCon          ( dataConName )
-import Control.Monad    ( when )
+import Literal             ( inCharRange )
+import TysWiredIn          ( nilDataCon )
+import DataCon             ( dataConName )
+import Control.Monad       ( when, liftM, ap )
 import Data.Ratio
 \end{code}
 
@@ -98,6 +98,13 @@ newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
                                             -> RnM (r, FreeVars) }
         -- See Note [CpsRn monad]
 
+instance Functor CpsRn where
+    fmap = liftM
+
+instance Applicative CpsRn where
+    pure = return
+    (<*>) = ap
+
 instance Monad CpsRn where
   return x = CpsRn (\k -> k x)
   (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 0af8201170..548e04c9cf 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -106,6 +106,7 @@ import Data.IORef
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Word
+import qualified Control.Applicative as A
 import Control.Monad
 
 import Prelude hiding   ( read )
@@ -819,10 +820,14 @@ instance Monad CoreM where
             let w = w1 `plusWriter` w2 -- forcing w before returning avoids a space leak (Trac #7702)
             return $ seq w (y, s'', w)
 
-instance Applicative CoreM where
+instance A.Applicative CoreM where
     pure = return
     (<*>) = ap
 
+instance MonadPlus IO => A.Alternative CoreM where
+    empty = mzero
+    (<|>) = mplus
+
 -- For use if the user has imported Control.Monad.Error from MTL
 -- Requires UndecidableInstances
 instance MonadPlus IO => MonadPlus CoreM where
diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 4c3c72d301..6a908836e2 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -29,7 +29,7 @@ import CoreMonad
 import Outputable
 import FastString
 import MonadUtils
-import Control.Monad    ( when )
+import Control.Monad       ( when, liftM, ap )
 \end{code}
 
 %************************************************************************
@@ -97,6 +97,14 @@ computeMaxTicks dflags size
 {-# INLINE thenSmpl_ #-}
 {-# INLINE returnSmpl #-}
 
+
+instance Functor SimplM where
+    fmap = liftM
+
+instance Applicative SimplM where
+    pure = return
+    (<*>) = ap
+
 instance Monad SimplM where
    (>>)   = thenSmpl_
    (>>=)  = thenSmpl
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index a175e5ed4b..b83cecf03c 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -34,6 +34,7 @@ import Outputable
 import FastString
 import State
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -1867,6 +1868,13 @@ data SpecState = SpecState {
                      spec_dflags :: DynFlags
                  }
 
+instance Functor SpecM where
+    fmap = liftM
+
+instance Applicative SpecM where
+    pure = return
+    (<*>) = ap
+
 instance Monad SpecM where
     SpecM x >>= f = SpecM $ do y <- x
                                case f y of
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index c87de4e65f..80b81a68e4 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -44,6 +44,8 @@ import ForeignCall
 import Demand           ( isSingleUsed )
 import PrimOp           ( PrimCall(..) )
 
+import Control.Monad (liftM, ap)
+
 -- Note [Live vs free]
 -- ~~~~~~~~~~~~~~~~~~~
 --
@@ -982,6 +984,13 @@ thenLne :: LneM a -> (a -> LneM b) -> LneM b
 thenLne m k = LneM $ \env lvs_cont
   -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
 
+instance Functor LneM where
+    fmap = liftM
+
+instance Applicative LneM where
+    pure = return
+    (<*>) = ap
+
 instance Monad LneM where
     return = returnLne
     (>>=)  = thenLne
diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs
index 3509a83849..04349db3df 100644
--- a/compiler/stgSyn/StgLint.lhs
+++ b/compiler/stgSyn/StgLint.lhs
@@ -25,6 +25,7 @@ import Util
 import SrcLoc
 import Outputable
 import FastString
+import Control.Applicative ( Applicative(..) )
 import Control.Monad
 import Data.Function
 
@@ -319,6 +320,13 @@ initL (LintM m)
         Just (vcat (punctuate blankLine (bagToList errs)))
     }
 
+instance Functor LintM where
+      fmap = liftM
+
+instance Applicative LintM where
+      pure = return
+      (<*>) = ap
+
 instance Monad LintM where
     return a = LintM $ \_loc _scope errs -> (a, errs)
     (>>=) = thenL
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 5091cab802..4f3971b7d7 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -48,6 +48,7 @@ import UniqSet
 import Util
 import Maybes
 import Data.List
+import Control.Applicative (Applicative(..))
 import Control.Monad
 \end{code}
 
@@ -772,6 +773,14 @@ data RoleInferenceInfo = RII { var_ns :: VarPositions
 newtype RoleM a = RM { unRM :: Maybe RoleInferenceInfo
                             -> RoleInferenceState
                             -> (a, RoleInferenceState) }
+
+instance Functor RoleM where
+    fmap = liftM
+
+instance Applicative RoleM where
+    pure = return
+    (<*>) = ap
+
 instance Monad RoleM where
   return x = RM $ \_ state -> (x, state)
   a >>= f  = RM $ \m_info state -> let (a', state') = unRM a m_info state in
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index af67808044..fddd1607c3 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -182,6 +182,8 @@ import Outputable
 import FastString
 
 import Data.IORef
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
 \end{code}
 
 %************************************************************************
@@ -1048,6 +1050,13 @@ data OccCheckResult a
   | OC_NonTyVar
   | OC_Occurs
 
+instance Functor OccCheckResult where
+      fmap = liftM
+
+instance Applicative OccCheckResult where
+      pure = return
+      (<*>) = ap
+
 instance Monad OccCheckResult where
   return x = OC_OK x
   OC_OK x     >>= k = k x
diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index 4b5d2ea63d..70170884dc 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -39,6 +39,9 @@ import Type
 import TyCon
 import TypeRep
 import Util
+
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
 \end{code}
 
 
@@ -649,6 +652,13 @@ data BindFlag
 newtype UM a = UM { unUM :: (TyVar -> BindFlag)
 		         -> UnifyResultM a }
 
+instance Functor UM where
+      fmap = liftM
+
+instance Applicative UM where
+      pure = return
+      (<*>) = ap
+
 instance Monad UM where
   return a = UM (\_tvs -> Unifiable a)
   fail _   = UM (\_tvs -> SurelyApart) -- failed pattern match
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 583e875903..04c11cf531 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -42,6 +42,7 @@ import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
 import Control.Monad
 import MonadUtils
+import Control.Applicative (Alternative(..))
 
 ----------------------------------------------------------------------
 -- Defining the monad type
@@ -150,9 +151,13 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
 
 
 ----------------------------------------------------------------------
--- MonadPlus
+-- Alternative/MonadPlus
 ----------------------------------------------------------------------
 
+instance MonadPlus IO => Alternative (IOEnv env) where
+      empty = mzero
+      (<|>) = mplus
+
 -- For use if the user has imported Control.Monad.Error from MTL
 -- Requires UndecidableInstances
 instance MonadPlus IO => MonadPlus (IOEnv env) where
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index a3fe632493..54e7e0c984 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -46,6 +46,7 @@ import Data.IORef
 import System.CPUTime
 import System.Environment
 import System.IO
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import GHC.Exts
 
@@ -168,13 +169,17 @@ reifyGHCi f = GHCi f'
 startGHCi :: GHCi a -> GHCiState -> Ghc a
 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
 
+instance Functor GHCi where
+    fmap = liftM
+
+instance Applicative GHCi where
+    pure = return
+    (<*>) = ap
+
 instance Monad GHCi where
   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
   return a  = GHCi $ \_ -> return a
 
-instance Functor GHCi where
-    fmap f m = m >>= return . f
-
 getGHCiState :: GHCi GHCiState
 getGHCiState   = GHCi $ \r -> liftIO $ readIORef r
 setGHCiState :: GHCiState -> GHCi ()
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 41ed265f4b..30acbe2eb8 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -34,6 +34,7 @@ import Data.Maybe
 
 import Data.Char ( isSpace, toLower )
 import Data.Ord (comparing)
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import System.Directory ( doesDirectoryExist, getDirectoryContents,
                           doesFileExist, renameFile, removeFile,
@@ -1303,6 +1304,13 @@ type ValidateWarning = String
 
 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
 
+instance Functor Validate where
+    fmap = liftM
+
+instance Applicative Validate where
+    pure = return
+    (<*>) = ap
+
 instance Monad Validate where
    return a = V $ return (a, [], [])
    m >>= k = V $ do