Commit e8ed2136 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺 Committed by Ben Gamari

Make Monad/Applicative instances MRP-friendly

This patch refactors pure/(*>) and return/(>>) in MRP-friendly way, i.e.
such that the explicit definitions for `return` and `(>>)` match the
MRP-style default-implementation, i.e.

  return = pure

and

  (>>) = (*>)

This way, e.g. all `return = pure` definitions can easily be grepped and
removed in GHC 8.1;

Test Plan: Harbormaster

Reviewers: goldfire, alanz, bgamari, quchen, austin

Reviewed By: quchen, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1312
parent 40cbf9aa
......@@ -105,9 +105,9 @@ takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }
instance Monad UniqSM where
return = returnUs
return = pure
(>>=) = thenUs
(>>) = thenUs_
(>>) = (*>)
instance Functor UniqSM where
fmap f (USM x) = USM (\us -> case x us of
......
......@@ -217,7 +217,7 @@ instance Functor CmmLint where
fmap = liftM
instance Applicative CmmLint where
pure = return
pure a = CmmLint (\_ -> Right a)
(<*>) = ap
instance Monad CmmLint where
......@@ -225,7 +225,7 @@ instance Monad CmmLint where
case m dflags of
Left e -> Left e
Right a -> unCL (k a) dflags
return a = CmmLint (\_ -> Right a)
return = pure
instance HasDynFlags CmmLint where
getDynFlags = CmmLint (\dflags -> Right dflags)
......
......@@ -1005,12 +1005,12 @@ instance Functor TE where
fmap = liftM
instance Applicative TE where
pure = return
pure a = TE $ \s -> (a, s)
(<*>) = 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)
return = pure
te_lbl :: CLabel -> TE ()
te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
......
......@@ -89,12 +89,12 @@ instance Functor CmmParse where
fmap = liftM
instance Applicative CmmParse where
pure = return
pure = returnExtFC
(<*>) = ap
instance Monad CmmParse where
(>>=) = thenExtFC
return = returnExtFC
return = pure
instance HasDynFlags CmmParse where
getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
......
......@@ -118,12 +118,12 @@ 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
pure = returnFC
(<*>) = ap
instance Monad FCode where
(>>=) = thenFC
return = returnFC
return = A.pure
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
......
......@@ -1491,11 +1491,11 @@ instance Functor LintM where
fmap = liftM
instance Applicative LintM where
pure = return
pure x = LintM $ \ _ errs -> (Just x, errs)
(<*>) = ap
instance Monad LintM where
return x = LintM (\ _ errs -> (Just x, errs))
return = pure
fail err = failWithL (text err)
m >>= k = LintM (\ env errs ->
let (res, errs') = unLintM m env errs in
......
......@@ -1016,11 +1016,11 @@ instance Functor TM where
fmap = liftM
instance Applicative TM where
pure = return
pure a = TM $ \ _env st -> (a,noFVs,st)
(<*>) = ap
instance Monad TM where
return a = TM $ \ _env st -> (a,noFVs,st)
return = pure
(TM m) >>= k = TM $ \ env st ->
case m env st of
(r1,fv1,st1) ->
......
......@@ -225,11 +225,11 @@ instance Functor Assembler where
fmap = liftM
instance Applicative Assembler where
pure = return
pure = NullAsm
(<*>) = ap
instance Monad Assembler where
return = NullAsm
return = pure
NullAsm x >>= f = f x
AllocPtr p k >>= f = AllocPtr p (k >=> f)
AllocLit l k >>= f = AllocLit l (k >=> f)
......
......@@ -1632,13 +1632,14 @@ instance Functor BcM where
fmap = liftM
instance Applicative BcM where
pure = return
pure = returnBc
(<*>) = ap
(*>) = thenBc_
instance Monad BcM where
(>>=) = thenBc
(>>) = thenBc_
return = returnBc
(>>) = (*>)
return = pure
instance HasDynFlags BcM where
getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
......
......@@ -86,11 +86,11 @@ instance Functor CvtM where
fmap = liftM
instance Applicative CvtM where
pure = return
pure x = CvtM $ \loc -> Right (loc,x)
(<*>) = ap
instance Monad CvtM where
return x = CvtM $ \loc -> Right (loc,x)
return = pure
(CvtM m) >>= k = CvtM $ \loc -> case m loc of
Left err -> Left err
Right (loc',v) -> unCvtM (k v) loc'
......
......@@ -208,11 +208,11 @@ instance Functor LlvmM where
return (f x, env')
instance Applicative LlvmM where
pure = return
pure x = LlvmM $ \env -> return (x, env)
(<*>) = ap
instance Monad LlvmM where
return x = LlvmM $ \env -> return (x, env)
return = pure
m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
runLlvmM (f x) env'
......
......@@ -100,13 +100,13 @@ instance Monad m => Functor (EwM m) where
fmap = liftM
instance Monad m => Applicative (EwM m) where
pure = return
pure v = EwM (\_ e w -> return (e, w, v))
(<*>) = 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')
return v = EwM (\_ e w -> return (e, w, v))
return = pure
runEwM :: EwM m a -> m (Errs, Warns, a)
runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
......@@ -146,7 +146,7 @@ instance Functor (CmdLineP s) where
fmap = liftM
instance Applicative (CmdLineP s) where
pure = return
pure a = CmdLineP $ \s -> (a, s)
(<*>) = ap
instance Monad (CmdLineP s) where
......@@ -154,7 +154,7 @@ instance Monad (CmdLineP s) where
let (a, s') = runCmdLine m s
in runCmdLine (k a) s'
return a = CmdLineP $ \s -> (a, s)
return = pure
getCmdLineState :: CmdLineP s s
getCmdLineState = CmdLineP $ \s -> (s,s)
......
......@@ -99,11 +99,11 @@ instance Functor Ghc where
fmap f m = Ghc $ \s -> f `fmap` unGhc m s
instance Applicative Ghc where
pure = return
pure a = Ghc $ \_ -> return a
g <*> m = do f <- g; a <- m; return (f a)
instance Monad Ghc where
return a = Ghc $ \_ -> return a
return = pure
m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
instance MonadIO Ghc where
......@@ -167,11 +167,11 @@ instance Applicative m => Applicative (GhcT m) where
pure x = GhcT $ \_ -> pure x
g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s
instance Monad m => Monad (GhcT m) where
return x = GhcT $ \_ -> return x
instance (Applicative m, Monad m) => Monad (GhcT m) where
return = pure
m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
instance MonadIO m => MonadIO (GhcT m) where
instance (Applicative m, MonadIO m) => MonadIO (GhcT m) where
liftIO ioA = GhcT $ \_ -> liftIO ioA
instance ExceptionMonad m => ExceptionMonad (GhcT m) where
......
......@@ -214,11 +214,11 @@ instance Functor Hsc where
fmap = liftM
instance Applicative Hsc where
pure = return
pure a = Hsc $ \_ w -> return (a, w)
(<*>) = ap
instance Monad Hsc where
return a = Hsc $ \_ w -> return (a, w)
return = pure
Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
case k a of
Hsc k' -> k' e w1
......
......@@ -27,11 +27,11 @@ instance Functor CompPipeline where
fmap = liftM
instance Applicative CompPipeline where
pure = return
pure a = P $ \_env state -> return (state, a)
(<*>) = ap
instance Monad CompPipeline where
return a = P $ \_env state -> return (state, a)
return = pure
P m >>= k = P $ \env state -> do (state',a) <- m env state
unP (k a) env state'
......
......@@ -771,11 +771,11 @@ instance Functor DFFV where
fmap = liftM
instance Applicative DFFV where
pure = return
pure a = DFFV $ \_ st -> (st, a)
(<*>) = ap
instance Monad DFFV where
return a = DFFV $ \_ st -> (st, a)
return = pure
(DFFV m) >>= k = DFFV $ \env st ->
case m env st of
(st',a) -> case k a of
......
......@@ -979,11 +979,11 @@ instance Functor CmmOptM where
fmap = liftM
instance Applicative CmmOptM where
pure = return
pure x = CmmOptM $ \_ _ imports -> (# x, imports #)
(<*>) = ap
instance Monad CmmOptM where
return x = CmmOptM $ \_ _ imports -> (# x, imports #)
return = pure
(CmmOptM f) >>= g =
CmmOptM $ \dflags this_mod imports ->
case f dflags this_mod imports of
......
......@@ -92,12 +92,12 @@ instance Functor NatM where
fmap = liftM
instance Applicative NatM where
pure = return
pure = returnNat
(<*>) = ap
instance Monad NatM where
(>>=) = thenNat
return = returnNat
return = pure
thenNat :: NatM a -> (a -> NatM b) -> NatM b
......
......@@ -56,12 +56,12 @@ instance Functor (RegM freeRegs) where
fmap = liftM
instance Applicative (RegM freeRegs) where
pure = return
pure a = RegM $ \s -> (# s, a #)
(<*>) = ap
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 #)
return = pure
instance HasDynFlags (RegM a) where
getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)
......
......@@ -1730,11 +1730,11 @@ instance Functor P where
fmap = liftM
instance Applicative P where
pure = return
pure = returnP
(<*>) = ap
instance Monad P where
return = returnP
return = pure
(>>=) = thenP
fail = failP
......
......@@ -643,11 +643,11 @@ instance Functor RuleM where
fmap = liftM
instance Applicative RuleM where
pure = return
pure x = RuleM $ \_ _ _ -> Just x
(<*>) = ap
instance Monad RuleM where
return x = RuleM $ \_ _ _ -> Just x
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
......
......@@ -231,13 +231,14 @@ instance Functor MassageM where
fmap = liftM
instance Applicative MassageM where
pure = return
pure x = MassageM (\_ ccs -> (ccs, x))
(<*>) = ap
(*>) = thenMM_
instance Monad MassageM where
return x = MassageM (\_ ccs -> (ccs, x))
return = pure
(>>=) = thenMM
(>>) = thenMM_
(>>) = (*>)
-- the initMM function also returns the final CollectedCCs
......
......@@ -102,11 +102,11 @@ instance Functor CpsRn where
fmap = liftM
instance Applicative CpsRn where
pure = return
pure x = CpsRn (\k -> k x)
(<*>) = ap
instance Monad CpsRn where
return x = CpsRn (\k -> k x)
return = pure
(CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
runCps :: CpsRn a -> RnM (a, FreeVars)
......
......@@ -555,12 +555,10 @@ type CoreIOEnv = IOEnv CoreReader
newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
instance Functor CoreM where
fmap f ma = do
a <- ma
return (f a)
fmap = liftM
instance Monad CoreM where
return x = CoreM (\s -> nop s x)
return = pure
mx >>= f = CoreM $ \s -> do
(x, s', w1) <- unCoreM mx s
(y, s'', w2) <- unCoreM (f x) s'
......@@ -568,10 +566,11 @@ instance Monad CoreM where
return $ seq w (y, s'', w)
-- forcing w before building the tuple avoids a space leak
-- (Trac #7702)
instance A.Applicative CoreM where
pure = return
pure x = CoreM $ \s -> nop s x
(<*>) = ap
(*>) = (>>)
m *> k = m >>= \_ -> k
instance MonadPlus IO => A.Alternative CoreM where
empty = mzero
......
......@@ -107,9 +107,9 @@ instance Applicative SimplM where
(*>) = thenSmpl_
instance Monad SimplM where
(>>) = thenSmpl_
(>>) = (*>)
(>>=) = thenSmpl
return = returnSmpl
return = pure
returnSmpl :: a -> SimplM a
returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
......
......@@ -2077,7 +2077,7 @@ instance Functor SpecM where
fmap = liftM
instance Applicative SpecM where
pure = return
pure x = SpecM $ return x
(<*>) = ap
instance Monad SpecM where
......@@ -2085,7 +2085,7 @@ instance Monad SpecM where
case f y of
SpecM z ->
z
return x = SpecM $ return x
return = pure
fail str = SpecM $ fail str
instance MonadUnique SpecM where
......
......@@ -990,11 +990,11 @@ instance Functor LneM where
fmap = liftM
instance Applicative LneM where
pure = return
pure = returnLne
(<*>) = ap
instance Monad LneM where
return = returnLne
return = pure
(>>=) = thenLne
instance MonadFix LneM where
......
......@@ -314,13 +314,14 @@ instance Functor LintM where
fmap = liftM
instance Applicative LintM where
pure = return
pure a = LintM $ \_loc _scope errs -> (a, errs)
(<*>) = ap
(*>) = thenL_
instance Monad LintM where
return a = LintM $ \_loc _scope errs -> (a, errs)
return = pure
(>>=) = thenL
(>>) = thenL_
(>>) = (*>)
thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL m k = LintM $ \loc scope errs
......
......@@ -528,7 +528,7 @@ newtype FlatM a
= FlatM { runFlatM :: FlattenEnv -> TcS a }
instance Monad FlatM where
return x = FlatM $ const (return x)
return = pure
m >>= k = FlatM $ \env ->
do { a <- runFlatM m env
; runFlatM (k a) env }
......@@ -537,7 +537,7 @@ instance Functor FlatM where
fmap = liftM
instance Applicative FlatM where
pure = return
pure x = FlatM $ const (pure x)
(<*>) = ap
liftTcS :: TcS a -> FlatM a
......
......@@ -2364,11 +2364,11 @@ instance Functor TcPluginM where
fmap = liftM
instance Applicative TcPluginM where
pure = return
pure x = TcPluginM (const $ pure x)
(<*>) = ap
instance Monad TcPluginM where
return x = TcPluginM (const $ return x)
return = pure
fail x = TcPluginM (const $ fail x)
TcPluginM m >>= k =
TcPluginM (\ ev -> do a <- m ev
......
......@@ -2158,11 +2158,11 @@ instance Functor TcS where
fmap f m = TcS $ fmap f . unTcS m
instance Applicative TcS where
pure = return
pure x = TcS (\_ -> return x)
(<*>) = ap
instance Monad TcS where
return x = TcS (\_ -> return x)
return = pure
fail err = TcS (\_ -> fail err)
m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
......
......@@ -805,11 +805,11 @@ instance Functor RoleM where
fmap = liftM
instance Applicative RoleM where
pure = return
pure x = RM $ \_ state -> (x, state)
(<*>) = ap
instance Monad RoleM where
return x = RM $ \_ state -> (x, state)
return = pure
a >>= f = RM $ \m_info state -> let (a', state') = unRM a m_info state in
unRM (f a') m_info state'
......
......@@ -1203,11 +1203,11 @@ instance Functor OccCheckResult where
fmap = liftM
instance Applicative OccCheckResult where
pure = return
pure = OC_OK
(<*>) = ap
instance Monad OccCheckResult where
return x = OC_OK x
return = pure
OC_OK x >>= k = k x
OC_Forall >>= _ = OC_Forall
OC_NonTyVar >>= _ = OC_NonTyVar
......
......@@ -708,11 +708,11 @@ instance Functor UM where
fmap = liftM
instance Applicative UM where
pure = return
pure a = UM (\_tvs subst -> Unifiable (a, subst))
(<*>) = ap
instance Monad UM where
return a = UM (\_tvs subst -> Unifiable (a, subst))
return = pure
fail _ = UM (\_tvs _subst -> SurelyApart) -- failed pattern match
m >>= k = UM (\tvs subst -> case unUM m tvs subst of
Unifiable (v, subst') -> unUM (k v) tvs subst'
......
......@@ -6,6 +6,7 @@ module Exception
)
where
import Control.Applicative as A
import Control.Exception
import Control.Monad.IO.Class
......@@ -28,7 +29,7 @@ tryIO = try
-- implementations of 'gbracket' and 'gfinally' use 'gmask'
-- thus rarely require overriding.
--
class MonadIO m => ExceptionMonad m where
class (A.Applicative m, MonadIO m) => ExceptionMonad m where
-- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
-- exception handling monad instead of just 'IO'.
......
......@@ -58,13 +58,14 @@ unIOEnv (IOEnv m) = m
instance Monad (IOEnv m) where
(>>=) = thenM
(>>) = thenM_
return = returnM
(>>) = (*>)
return = pure
fail _ = failM -- Ignore the string