Commit b20cf4ec authored by Austin Seipp's avatar Austin Seipp

Fix AMP warnings.

Authored-by: quchen's avatarDavid Luposchainsky <dluposchainsky@gmail.com>
Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent 1ef941a8
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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_
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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 =
......
......@@ -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
......
......@@ -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 #)
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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