diff options
40 files changed, 113 insertions, 99 deletions
diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs index 67248db72d..b84270a571 100644 --- a/compiler/basicTypes/UniqSupply.hs +++ b/compiler/basicTypes/UniqSupply.hs @@ -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 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 63a3ff5de3..a2ccfbeecf 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -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) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index c96b7076bf..76659caa8f 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -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)) diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index 2091d9b358..50015989e0 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -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 diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 3d055e75bb..3083bfffc4 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -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 #-} diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index ea1d9689b7..da08c21fca 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index b9ef0f1c03..8d9f37d24e 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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) -> diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index efcca14fbb..c69cede7f3 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -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) diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 347b3987f2..b06d1a4b3f 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -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) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 90fcfbc79d..f514863791 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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' diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 510d01f1d7..7a673b8ec3 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -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' diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index dad7ea7ae2..823f25ea71 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -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) diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 5b2e4228bb..44f9effdaa 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -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 diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 317a9413ec..a2a2f50224 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -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 diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs index 31f9169c47..e66b199305 100644 --- a/compiler/main/PipelineMonad.hs +++ b/compiler/main/PipelineMonad.hs @@ -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' diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index e2a772f8d4..122440133f 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -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 diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index d84578805b..1b57a504bd 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -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 diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index fcb7b90d0d..35a00270a3 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -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 diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 287bdc65e4..9602d251c6 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -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 #) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index db2d8473cc..acb6893b66 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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 diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index f87dce4798..919a1d51fe 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -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 diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs index dfa3d052a4..26e54705c5 100644 --- a/compiler/profiling/SCCfinal.hs +++ b/compiler/profiling/SCCfinal.hs @@ -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 diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index f6d02eb2c8..053d4addc9 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -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) diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 0a1c782162..ce5286d08a 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -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 diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs index c8503a7f3f..b8453581de 100644 --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -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)) diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 008561c4b3..31d8212831 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -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 diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index dc70851205..e5954ab440 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -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 diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index b415b4f2d9..ef5dd9237a 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -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 diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index efc9e32302..a3724a1276 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -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 diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 1ff3bdaf4b..c046704643 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -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 diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index b782a20ef2..5303925237 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -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) diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 827f21793c..a74c9e32c0 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -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' diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index bb937c687b..13422d9020 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -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 diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index b816558a02..de22066f9d 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -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' diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index 850393e359..8168992e00 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -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'. diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index fae3b9634f..31ac2b3731 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -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)) diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs index 84e2d97d56..56b6dab5d9 100644 --- a/compiler/utils/Maybes.hs +++ b/compiler/utils/Maybes.hs @@ -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 diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs index 7346841613..a1903cee76 100644 --- a/compiler/utils/State.hs +++ b/compiler/utils/State.hs @@ -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' diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs index edb0b0c558..fcef97b654 100644 --- a/compiler/utils/Stream.hs +++ b/compiler/utils/Stream.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs index a3089e3e62..f043f2552e 100644 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -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 |