Make Monad/Applicative instances MRP-friendly
authorHerbert Valerio Riedel <hvr@gnu.org>
Sat, 17 Oct 2015 14:47:51 +0000 (16:47 +0200)
committerBen Gamari <ben@smart-cactus.org>
Sat, 17 Oct 2015 14:51:33 +0000 (16:51 +0200)
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

40 files changed:
compiler/basicTypes/UniqSupply.hs
compiler/cmm/CmmLint.hs
compiler/cmm/PprC.hs
compiler/codeGen/StgCmmExtCode.hs
compiler/codeGen/StgCmmMonad.hs
compiler/coreSyn/CoreLint.hs
compiler/deSugar/Coverage.hs
compiler/ghci/ByteCodeAsm.hs
compiler/ghci/ByteCodeGen.hs
compiler/hsSyn/Convert.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/main/CmdLineParser.hs
compiler/main/GhcMonad.hs
compiler/main/HscTypes.hs
compiler/main/PipelineMonad.hs
compiler/main/TidyPgm.hs
compiler/nativeGen/AsmCodeGen.hs
compiler/nativeGen/NCGMonad.hs
compiler/nativeGen/RegAlloc/Linear/State.hs
compiler/parser/Lexer.x
compiler/prelude/PrelRules.hs
compiler/profiling/SCCfinal.hs
compiler/rename/RnPat.hs
compiler/simplCore/CoreMonad.hs
compiler/simplCore/SimplMonad.hs
compiler/specialise/Specialise.hs
compiler/stgSyn/CoreToStg.hs
compiler/stgSyn/StgLint.hs
compiler/typecheck/TcFlatten.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcTyDecls.hs
compiler/typecheck/TcType.hs
compiler/types/Unify.hs
compiler/utils/Exception.hs
compiler/utils/IOEnv.hs
compiler/utils/Maybes.hs
compiler/utils/State.hs
compiler/utils/Stream.hs
compiler/vectorise/Vectorise/Monad/Base.hs

index 67248db..b84270a 100644 (file)
@@ -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
index 63a3ff5..a2ccfbe 100644 (file)
@@ -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)
index c96b707..76659ca 100644 (file)
@@ -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))
index 2091d9b..5001598 100644 (file)
@@ -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
index 3d055e7..3083bff 100644 (file)
@@ -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 #-}
index ea1d968..da08c21 100644 (file)
@@ -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
index b9ef0f1..8d9f37d 100644 (file)
@@ -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) ->
index efcca14..c69cede 100644 (file)
@@ -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)
index 347b398..b06d1a4 100644 (file)
@@ -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)
index 90fcfbc..f514863 100644 (file)
@@ -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'
index 510d01f..7a673b8 100644 (file)
@@ -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'
 
index dad7ea7..823f25e 100644 (file)
@@ -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)
index 5b2e422..44f9eff 100644 (file)
@@ -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
index 317a941..a2a2f50 100644 (file)
@@ -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
index 31f9169..e66b199 100644 (file)
@@ -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'
 
index e2a772f..1224401 100644 (file)
@@ -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
index d845788..1b57a50 100644 (file)
@@ -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
index fcb7b90..35a0027 100644 (file)
@@ -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
index 287bdc6..9602d25 100644 (file)
@@ -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 #)
index db2d847..acb6893 100644 (file)
@@ -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
 
index f87dce4..919a1d5 100644 (file)
@@ -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
index dfa3d05..26e5470 100644 (file)
@@ -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
 
index f6d02eb..053d4ad 100644 (file)
@@ -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)
index 0a1c782..ce5286d 100644 (file)
@@ -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
index c8503a7..b845358 100644 (file)
@@ -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))
index 008561c..31d8212 100644 (file)
@@ -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
index dc70851..e5954ab 100644 (file)
@@ -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
index b415b4f..ef5dd92 100644 (file)
@@ -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
index efc9e32..a3724a1 100644 (file)
@@ -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
index 1ff3bda..c046704 100644 (file)
@@ -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
index b782a20..5303925 100644 (file)
@@ -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)
 
index 827f217..a74c9e3 100644 (file)
@@ -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'
 
index bb937c6..13422d9 100644 (file)
@@ -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
index b816558..de22066 100644 (file)
@@ -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'
index 850393e..8168992 100644 (file)
@@ -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'.
index fae3b96..31ac2b3 100644 (file)
@@ -58,13 +58,14 @@ unIOEnv (IOEnv m) = m
 
 instance Monad (IOEnv m) where
     (>>=)  = thenM
-    (>>)   = thenM_
-    return = returnM
+    (>>)   = (*>)
+    return = pure
     fail _ = failM -- Ignore the string
 
 instance Applicative (IOEnv m) where
     pure = returnM
     IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
+    (*>) = thenM_
 
 instance Functor (IOEnv m) where
     fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))
index 84e2d97..56b6dab 100644 (file)
@@ -68,32 +68,42 @@ instance Functor m => Functor (MaybeT m) where
 
 #if __GLASGOW_HASKELL__ < 710
 -- Pre-AMP change
-instance (Monad m, Functor m) => Applicative (MaybeT m) where
+instance (Monad m, Applicative m) => Applicative (MaybeT m) where
 #else
 instance (Monad m) => Applicative (MaybeT m) where
 #endif
-  pure  = return
+  pure = MaybeT . pure . Just
   (<*>) = ap
 
-instance Monad m => Monad (MaybeT m) where
-  return = MaybeT . return . Just
-  x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f)
-  fail _ = MaybeT $ return Nothing
+#if __GLASGOW_HASKELL__ < 710
+-- Pre-AMP change
+instance (Monad m, Applicative m) => Monad (MaybeT m) where
+#else
+instance (Monad m) => Monad (MaybeT m) where
+#endif
+  return = pure
+  x >>= f = MaybeT $ runMaybeT x >>= maybe (pure Nothing) (runMaybeT . f)
+  fail _ = MaybeT $ pure Nothing
 
 #if __GLASGOW_HASKELL__ < 710
 -- Pre-AMP change
-instance (Monad m, Functor m) => Alternative (MaybeT m) where
+instance (Monad m, Applicative m) => Alternative (MaybeT m) where
 #else
 instance (Monad m) => Alternative (MaybeT m) where
 #endif
   empty = mzero
   (<|>) = mplus
 
+#if __GLASGOW_HASKELL__ < 710
+-- Pre-AMP change
+instance (Monad m, Applicative m) => MonadPlus (MaybeT m) where
+#else
 instance Monad m => MonadPlus (MaybeT m) where
-  mzero       = MaybeT $ return Nothing
+#endif
+  mzero       = MaybeT $ pure Nothing
   p `mplus` q = MaybeT $ do ma <- runMaybeT p
                             case ma of
-                              Just a  -> return (Just a)
+                              Just a  -> pure (Just a)
                               Nothing -> runMaybeT q
 
 liftMaybeT :: Monad m => m a -> MaybeT m a
@@ -113,11 +123,11 @@ instance Functor (MaybeErr err) where
   fmap = liftM
 
 instance Applicative (MaybeErr err) where
-  pure  = return
+  pure  = Succeeded
   (<*>) = ap
 
 instance Monad (MaybeErr err) where
-  return v = Succeeded v
+  return = pure
   Succeeded v >>= k = k v
   Failed e    >>= _ = Failed e
 
index 7346841..a1903ce 100644 (file)
@@ -19,7 +19,7 @@ instance Applicative (State s) where
                                            (# x, s'' #) -> (# f x, s'' #)
 
 instance Monad (State s) where
-    return x = State $ \s -> (# x, s #)
+    return = pure
     m >>= n  = State $ \s -> case runState' m s of
                              (# r, s' #) -> runState' (n r) s'
 
index edb0b0c..fcef97b 100644 (file)
@@ -46,11 +46,11 @@ instance Monad f => Functor (Stream f a) where
   fmap = liftM
 
 instance Monad m => Applicative (Stream m a) where
-  pure  = return
+  pure a = Stream (return (Left a))
   (<*>) = ap
 
 instance Monad m => Monad (Stream m a) where
-  return a = Stream (return (Left a))
+  return = pure
 
   Stream m >>= k = Stream $ do
                 r <- m
index a3089e3..f043f25 100644 (file)
@@ -51,7 +51,7 @@ newtype VM a
   = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
 
 instance Monad VM where
-  return x   = VM $ \_  genv lenv -> return (Yes genv lenv x)
+  return = pure
   VM p >>= f = VM $ \bi genv lenv -> do
                                        r <- p bi genv lenv
                                        case r of
@@ -59,7 +59,7 @@ instance Monad VM where
                                          No reason         -> return $ No reason
 
 instance Applicative VM where
-  pure  = return
+  pure x = VM $ \_ genv lenv -> return (Yes genv lenv x)
   (<*>) = ap
   
 instance Functor VM where