Commit 3c8cb7f4 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Remove some redundant definitions/constraints

Starting with GHC 7.10 and base-4.8, `Monad` implies `Applicative`,
which allows to simplify some definitions to exploit the superclass
relationship. This a first refactoring to that end.
parent 2f923ce2
......@@ -127,7 +127,6 @@ splitUniqSupply4 us = (us1, us2, us3, us4)
newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }
instance Monad UniqSM where
return = pure
(>>=) = thenUs
(>>) = (*>)
......
......@@ -222,7 +222,6 @@ instance Monad CmmLint where
case m dflags of
Left e -> Left e
Right a -> unCL (k a) dflags
return = pure
instance HasDynFlags CmmLint where
getDynFlags = CmmLint (\dflags -> Right dflags)
......
......@@ -1008,7 +1008,6 @@ instance Applicative TE where
instance Monad TE where
TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
return = pure
te_lbl :: CLabel -> TE ()
te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
......
......@@ -89,7 +89,6 @@ instance Applicative CmmParse where
instance Monad CmmParse where
(>>=) = thenExtFC
return = pure
instance HasDynFlags CmmParse where
getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
......
......@@ -77,7 +77,6 @@ import UniqSupply
import FastString
import Outputable
import qualified Control.Applicative as A
import Control.Monad
import Data.List
import Prelude hiding( sequence, succ )
......@@ -117,13 +116,12 @@ 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
instance Applicative FCode where
pure = returnFC
(<*>) = ap
instance Monad FCode where
(>>=) = thenFC
return = A.pure
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
......
......@@ -1576,7 +1576,6 @@ instance Applicative LintM where
(<*>) = ap
instance Monad LintM where
return = pure
fail err = failWithL (text err)
m >>= k = LintM (\ env errs ->
let (res, errs') = unLintM m env errs in
......
......@@ -1055,7 +1055,6 @@ instance Applicative TM where
(<*>) = ap
instance Monad TM where
return = pure
(TM m) >>= k = TM $ \ env st ->
case m env st of
(r1,fv1,st1) ->
......
......@@ -170,7 +170,6 @@ instance Applicative Assembler where
(<*>) = ap
instance Monad Assembler where
return = pure
NullAsm x >>= f = f x
AllocPtr p k >>= f = AllocPtr p (k >=> f)
AllocLit l k >>= f = AllocLit l (k >=> f)
......
......@@ -1684,7 +1684,6 @@ instance Applicative BcM where
instance Monad BcM where
(>>=) = thenBc
(>>) = (*>)
return = pure
instance HasDynFlags BcM where
getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
......
......@@ -87,7 +87,6 @@ instance Applicative CvtM where
(<*>) = ap
instance Monad CvtM where
return = pure
(CvtM m) >>= k = CvtM $ \loc -> case m loc of
Left err -> Left err
Right (loc',v) -> unCvtM (k v) loc'
......
......@@ -218,7 +218,6 @@ instance Applicative LlvmM where
(<*>) = ap
instance Monad LlvmM where
return = pure
m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
runLlvmM (f x) env'
......
......@@ -103,7 +103,6 @@ instance Monad m => Applicative (EwM m) where
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')
return = pure
runEwM :: EwM m a -> m (Errs, Warns, a)
runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
......@@ -151,7 +150,6 @@ instance Monad (CmdLineP s) where
let (a, s') = runCmdLine m s
in runCmdLine (k a) s'
return = pure
getCmdLineState :: CmdLineP s s
getCmdLineState = CmdLineP $ \s -> (s,s)
......
......@@ -104,7 +104,6 @@ instance Applicative Ghc where
g <*> m = do f <- g; a <- m; return (f a)
instance Monad Ghc where
return = pure
m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
instance MonadIO Ghc where
......@@ -168,11 +167,10 @@ instance Applicative m => Applicative (GhcT m) where
pure x = GhcT $ \_ -> pure x
g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s
instance (Applicative m, Monad m) => Monad (GhcT m) where
return = pure
instance Monad m => Monad (GhcT m) where
m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
instance (Applicative m, MonadIO m) => MonadIO (GhcT m) where
instance MonadIO m => MonadIO (GhcT m) where
liftIO ioA = GhcT $ \_ -> liftIO ioA
instance ExceptionMonad m => ExceptionMonad (GhcT m) where
......
......@@ -228,7 +228,6 @@ instance Applicative Hsc where
(<*>) = ap
instance Monad Hsc where
return = pure
Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
case k a of
Hsc k' -> k' e w1
......
......@@ -31,7 +31,6 @@ instance Applicative CompPipeline where
(<*>) = ap
instance Monad CompPipeline where
return = pure
P m >>= k = P $ \env state -> do (state',a) <- m env state
unP (k a) env state'
......
......@@ -775,7 +775,6 @@ instance Applicative DFFV where
(<*>) = ap
instance Monad DFFV where
return = pure
(DFFV m) >>= k = DFFV $ \env st ->
case m env st of
(st',a) -> case k a of
......
......@@ -983,7 +983,6 @@ instance Applicative CmmOptM where
(<*>) = ap
instance Monad CmmOptM where
return = pure
(CmmOptM f) >>= g =
CmmOptM $ \dflags this_mod imports ->
case f dflags this_mod imports of
......
......@@ -94,7 +94,6 @@ instance Applicative NatM where
instance Monad NatM where
(>>=) = thenNat
return = pure
thenNat :: NatM a -> (a -> NatM b) -> NatM b
......
......@@ -57,7 +57,6 @@ instance Applicative (RegM freeRegs) where
instance Monad (RegM freeRegs) where
m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
return = pure
instance HasDynFlags (RegM a) where
getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)
......
......@@ -1783,7 +1783,6 @@ instance Applicative P where
(<*>) = ap
instance Monad P where
return = pure
(>>=) = thenP
fail = failP
......
......@@ -645,7 +645,6 @@ instance Applicative RuleM where
(<*>) = ap
instance Monad RuleM where
return = pure
RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
Nothing -> Nothing
Just r -> runRuleM (g r) dflags iu e
......
......@@ -233,7 +233,6 @@ instance Applicative MassageM where
(*>) = thenMM_
instance Monad MassageM where
return = pure
(>>=) = thenMM
(>>) = (*>)
......
......@@ -107,7 +107,6 @@ instance Applicative CpsRn where
(<*>) = ap
instance Monad CpsRn where
return = pure
(CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
runCps :: CpsRn a -> RnM (a, FreeVars)
......
......@@ -88,8 +88,8 @@ 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 Control.Applicative ( Alternative(..) )
import Prelude hiding ( read )
......@@ -557,7 +557,6 @@ instance Functor CoreM where
fmap = liftM
instance Monad CoreM where
return = pure
mx >>= f = CoreM $ \s -> do
(x, s', w1) <- unCoreM mx s
(y, s'', w2) <- unCoreM (f x) s'
......@@ -566,12 +565,12 @@ instance Monad CoreM where
-- forcing w before building the tuple avoids a space leak
-- (Trac #7702)
instance A.Applicative CoreM where
instance Applicative CoreM where
pure x = CoreM $ \s -> nop s x
(<*>) = ap
m *> k = m >>= \_ -> k
instance MonadPlus IO => A.Alternative CoreM where
instance MonadPlus IO => Alternative CoreM where
empty = mzero
(<|>) = mplus
......
......@@ -109,7 +109,6 @@ instance Applicative SimplM where
instance Monad SimplM where
(>>) = (*>)
(>>=) = thenSmpl
return = pure
returnSmpl :: a -> SimplM a
returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
......
......@@ -2091,7 +2091,6 @@ instance Monad SpecM where
case f y of
SpecM z ->
z
return = pure
fail str = SpecM $ fail str
#if __GLASGOW_HASKELL__ > 710
......
......@@ -994,7 +994,6 @@ instance Applicative LneM where
(<*>) = ap
instance Monad LneM where
return = pure
(>>=) = thenLne
instance MonadFix LneM where
......
......@@ -315,7 +315,6 @@ instance Applicative LintM where
(*>) = thenL_
instance Monad LintM where
return = pure
(>>=) = thenL
(>>) = (*>)
......
......@@ -526,7 +526,6 @@ newtype FlatM a
= FlatM { runFlatM :: FlattenEnv -> TcS a }
instance Monad FlatM where
return = pure
m >>= k = FlatM $ \env ->
do { a <- runFlatM m env
; runFlatM (k a) env }
......
......@@ -2903,7 +2903,6 @@ instance Applicative TcPluginM where
(<*>) = ap
instance Monad TcPluginM where
return = pure
fail x = TcPluginM (const $ fail x)
TcPluginM m >>= k =
TcPluginM (\ ev -> do a <- m ev
......
......@@ -2246,7 +2246,6 @@ instance Applicative TcS where
(<*>) = ap
instance Monad TcS where
return = pure
fail err = TcS (\_ -> fail err)
m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
......
......@@ -788,7 +788,6 @@ instance Applicative RoleM where
(<*>) = ap
instance Monad RoleM where
return = pure
a >>= f = RM $ \m_info vps nvps state ->
let (a', state') = unRM a m_info vps nvps state in
unRM (f a') m_info vps nvps state'
......
......@@ -1433,7 +1433,6 @@ instance Applicative OccCheckResult where
(<*>) = ap
instance Monad OccCheckResult where
return = pure
OC_OK x >>= k = k x
OC_Forall >>= _ = OC_Forall
OC_NonTyVar >>= _ = OC_NonTyVar
......
......@@ -1378,7 +1378,6 @@ withLC :: LiftingContext -> NormM a -> NormM a
withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r
instance Monad NormM where
return = pure
ma >>= fmb = NormM $ \env lc r ->
let a = runNormM ma env lc r in
runNormM (fmb a) env lc r
......
......@@ -437,7 +437,7 @@ data TyCoMapper env m
}
{-# INLINABLE mapType #-} -- See Note [Specialising mappers]
mapType :: (Applicative m, Monad m) => TyCoMapper env m -> env -> Type -> m Type
mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type
mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar
, tcm_tybinder = tybinder })
env ty
......@@ -460,7 +460,7 @@ mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar
| otherwise = (TyConApp, AppTy, CastTy, ForAllTy . Anon)
{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers]
mapCoercion :: (Applicative m, Monad m)
mapCoercion :: Monad m
=> TyCoMapper env m -> env -> Coercion -> m Coercion
mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar
, tcm_hole = cohole, tcm_tybinder = tybinder })
......
......@@ -374,7 +374,6 @@ instance Applicative UnifyResultM where
(<*>) = ap
instance Monad UnifyResultM where
return = pure
SurelyApart >>= _ = SurelyApart
MaybeApart x >>= f = case f x of
......@@ -908,7 +907,6 @@ instance Applicative UM where
(<*>) = ap
instance Monad UM where
return = pure
fail _ = UM (\_ _ -> SurelyApart) -- failed pattern match
m >>= k = UM (\env state ->
do { (state', v) <- unUM m env state
......
......@@ -6,7 +6,6 @@ module Exception
)
where
import Control.Applicative as A
import Control.Exception
import Control.Monad.IO.Class
......@@ -29,7 +28,7 @@ tryIO = try
-- implementations of 'gbracket' and 'gfinally' use 'gmask'
-- thus rarely require overriding.
--
class (A.Applicative m, MonadIO m) => ExceptionMonad m where
class MonadIO m => ExceptionMonad m where
-- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
-- exception handling monad instead of just 'IO'.
......
......@@ -62,7 +62,6 @@ unIOEnv (IOEnv m) = m
instance Monad (IOEnv m) where
(>>=) = thenM
(>>) = (*>)
return = pure
fail _ = failM -- Ignore the string
#if __GLASGOW_HASKELL__ > 710
......
......@@ -17,7 +17,6 @@ module Maybes (
MaybeT(..), liftMaybeT
) where
import Control.Applicative as A
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Maybe
......@@ -84,7 +83,6 @@ instance Applicative (MaybeErr err) where
(<*>) = ap
instance Monad (MaybeErr err) where
return = A.pure
Succeeded v >>= k = k v
Failed e >>= _ = Failed e
......
......@@ -15,7 +15,6 @@ instance Applicative (State s) where
(# x, s'' #) -> (# f x, s'' #)
instance Monad (State s) where
return = pure
m >>= n = State $ \s -> case runState' m s of
(# r, s' #) -> runState' (n r) s'
......
......@@ -46,7 +46,6 @@ instance Monad m => Applicative (Stream m a) where
(<*>) = ap
instance Monad m => Monad (Stream m a) where
return = pure
Stream m >>= k = Stream $ do
r <- m
......
......@@ -51,7 +51,6 @@ newtype VM a
= VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
instance Monad VM where
return = pure
VM p >>= f = VM $ \bi genv lenv -> do
r <- p bi genv lenv
case r of
......
......@@ -72,7 +72,6 @@ instance Monad GHCiQ where
do (m', s') <- runGHCiQ m s
(a, s'') <- runGHCiQ (f m') s'
return (a, s'')
return = pure
fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)
getState :: GHCiQ QState
......
......@@ -155,7 +155,6 @@ instance Applicative PprM where
(<*>) = ap
instance Monad PprM where
return = pure
m >>= k = PprM $ \s -> let (x, s') = runPprM m s
in runPprM (k x) s'
......
......@@ -52,7 +52,7 @@ import Numeric.Natural
--
-----------------------------------------------------
class (Applicative m, Monad m) => Quasi m where
class Monad m => Quasi m where
qNewName :: String -> m Name
-- ^ Fresh names
......@@ -170,7 +170,6 @@ runQ (Q m) = m
instance Monad Q where
Q m >>= k = Q (m >>= \x -> unQ (k x))
(>>) = (*>)
return = pure
fail s = report True s >> Q (fail "Q monad failure")
instance Functor Q where
......
......@@ -1517,7 +1517,6 @@ instance Applicative Validate where
(<*>) = ap
instance Monad Validate where
return = pure
m >>= k = V $ do
(a, es, ws) <- runValidate m
(b, es', ws') <- runValidate (k a)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment