Fix AMP warnings.

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

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

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)

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

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

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)

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

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 ->

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

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_

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

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)

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

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

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

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 ->

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 =

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

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 #)

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 ->

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