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

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