diff options
32 files changed, 283 insertions, 20 deletions
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 92a137b98b..970ce68149 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -21,6 +21,8 @@ import Outputable import DynFlags import Data.Maybe +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) -- Things to check: -- - invariant on CmmBlock in CmmExpr (see comment there) @@ -207,6 +209,13 @@ checkCond _ expr newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } +instance Functor CmmLint where + fmap = liftM + +instance Applicative CmmLint where + pure = return + (<*>) = ap + instance Monad CmmLint where CmmLint m >>= k = CmmLint $ \dflags -> case m dflags of diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 149968d118..d45b103954 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -52,6 +52,8 @@ import Data.Map (Map) import Data.Word import System.IO import qualified Data.Map as Map +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) import Data.Array.Unsafe ( castSTUArray ) import Data.Array.ST hiding ( castSTUArray ) @@ -986,6 +988,13 @@ pprExternDecl _in_srt lbl type TEState = (UniqSet LocalReg, Map CLabel ()) newtype TE a = TE { unTE :: TEState -> (a, TEState) } +instance Functor TE where + fmap = liftM + +instance Applicative TE where + pure = return + (<*>) = 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) diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index e710204222..df1733978f 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -48,6 +48,9 @@ import Module import UniqFM import Unique +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) + -- | The environment contains variable definitions or blockids. data Named @@ -76,6 +79,13 @@ returnExtFC a = EC $ \_ s -> return (s, a) thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' +instance Functor CmmParse where + fmap = liftM + +instance Applicative CmmParse where + pure = return + (<*>) = ap + instance Monad CmmParse where (>>=) = thenExtFC return = returnExtFC diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 27d4fd6386..3d82e69402 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -74,6 +74,7 @@ import UniqSupply import FastString import Outputable +import qualified Control.Applicative as A import Control.Monad import Data.List import Prelude hiding( sequence, succ ) @@ -113,6 +114,10 @@ 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 + pure = return + (<*>) = ap + instance Monad FCode where (>>=) = thenFC return = returnFC diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 1913e3ab93..ffddd78516 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -1025,6 +1025,13 @@ The same substitution also supports let-type, current expressed as Here we substitute 'ty' for 'a' in 'body', on the fly. -} +instance Functor LintM where + fmap = liftM + +instance Applicative LintM where + pure = return + (<*>) = ap + instance Monad LintM where return x = LintM (\ _ _ errs -> (Just x, errs)) fail err = failWithL (text err) diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index a0776af218..bdb54d80d6 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -32,6 +32,7 @@ import DynFlags import FastString import Exception +import Control.Applicative (Applicative(..)) import Control.Monad import qualified Data.ByteString as BS import Data.Char @@ -55,6 +56,14 @@ data CoreState = CoreState { cs_dflags :: DynFlags, cs_module :: Module } + +instance Functor CoreM where + fmap = liftM + +instance Applicative CoreM where + pure = return + (<*>) = ap + instance Monad CoreM where (CoreM m) >>= f = CoreM (\ s -> case m s of (s',r) -> case f r of diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index bdcf9c9f78..889155c79e 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -964,6 +964,13 @@ data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTrans -- a combination of a state monad (TickTransState) and a writer -- monad (FreeVars). +instance Functor TM where + fmap = liftM + +instance Applicative TM where + pure = return + (<*>) = ap + instance Monad TM where return a = TM $ \ _env st -> (a,noFVs,st) (TM m) >>= k = TM $ \ env st -> diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index e3119a7842..dd8bbe4c83 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -35,6 +35,7 @@ import Outputable import Platform import Util +import Control.Applicative (Applicative(..)) import Control.Monad import Control.Monad.ST ( runST ) import Control.Monad.Trans.Class @@ -223,6 +224,13 @@ data Assembler a | Emit Word16 [Operand] (Assembler a) | NullAsm a +instance Functor Assembler where + fmap = liftM + +instance Applicative Assembler where + pure = return + (<*>) = ap + instance Monad Assembler where return = NullAsm NullAsm x >>= f = f x diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 9c9526de27..ee4895db95 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -55,6 +55,7 @@ import Data.List import Foreign import Foreign.C +import Control.Applicative (Applicative(..)) import Control.Monad import Data.Char @@ -1586,6 +1587,13 @@ thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do returnBc :: a -> BcM a returnBc result = BcM $ \st -> (return (st, result)) +instance Functor BcM where + fmap = liftM + +instance Applicative BcM where + pure = return + (<*>) = ap + instance Monad BcM where (>>=) = thenBc (>>) = thenBc_ diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 383b641262..8a4f7d8783 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -32,7 +32,8 @@ import FastString import Outputable import qualified Data.ByteString as BS -import Control.Monad( unless ) +import Control.Monad( unless, liftM, ap ) +import Control.Applicative (Applicative(..)) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -72,6 +73,13 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a } -- In particular, we want it on binding locations, so that variables bound in -- the spliced-in declarations get a location that at least relates to the splice point +instance Functor CvtM where + fmap = liftM + +instance Applicative CvtM where + pure = return + (<*>) = ap + instance Monad CvtM where return x = CvtM $ \_ -> Right x (CvtM m) >>= k = CvtM $ \loc -> case m loc of diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index dda2c9e05b..6ae3c4252d 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -54,6 +54,9 @@ import UniqSupply import ErrUtils import qualified Stream +import Control.Monad (ap) +import Control.Applicative (Applicative(..)) + -- ---------------------------------------------------------------------------- -- * Some Data Types -- @@ -209,13 +212,19 @@ type LlvmEnvMap = UniqFM LlvmType -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } + +instance Functor LlvmM where + fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env + return (f x, env') + +instance Applicative LlvmM where + pure = return + (<*>) = ap + instance Monad LlvmM where return x = LlvmM $ \env -> return (x, env) m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env runLlvmM (f x) env' -instance Functor LlvmM where - fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env - return (f x, env') instance HasDynFlags LlvmM where getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 252a376432..6681186246 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -30,6 +30,9 @@ import SrcLoc import Data.Function import Data.List +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) + -------------------------------------------------------- -- The Flag and OptKind types @@ -72,6 +75,13 @@ newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg -> Errs -> Warns -> m (Errs, Warns, a) } +instance Monad m => Functor (EwM m) where + fmap = liftM + +instance Monad m => Applicative (EwM m) where + pure = return + (<*>) = 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') @@ -108,6 +118,13 @@ liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } +instance Functor (CmdLineP s) where + fmap = liftM + +instance Applicative (CmdLineP s) where + pure = return + (<*>) = ap + instance Monad (CmdLineP s) where m >>= k = CmdLineP $ \s -> let (a, s') = runCmdLine m s diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 7c5bc90647..a6567c8c39 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -669,6 +669,13 @@ newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a evalP f env st = liftM snd $ unP f env st +instance Functor CompPipeline where + fmap = liftM + +instance Applicative CompPipeline where + pure = return + (<*>) = ap + instance Monad CompPipeline where return a = P $ \_env state -> return (state, a) P m >>= k = P $ \env state -> do (state',a) <- m env state diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index ad1b7c503a..774f5be488 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -194,6 +194,13 @@ knownKeyNames = -- where templateHaskellNames are defined newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) +instance Functor Hsc where + fmap = liftM + +instance Applicative Hsc where + pure = return + (<*>) = ap + instance Monad Hsc where return a = Hsc $ \_ w -> return (a, w) Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w @@ -203,9 +210,6 @@ instance Monad Hsc where instance MonadIO Hsc where liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) -instance Functor Hsc where - fmap f m = m >>= \a -> return $ f a - runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyBag diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index d6a3da13e6..9886fe394f 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -749,6 +749,13 @@ newtype DFFV a -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far -> ((VarSet,[Var]),a)) -- Output state +instance Functor DFFV where + fmap = liftM + +instance Applicative DFFV where + pure = return + (<*>) = ap + instance Monad DFFV where return a = DFFV $ \_ st -> (st, a) (DFFV m) >>= k = DFFV $ \env st -> diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 42eeb4ff13..cd00a8295d 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -80,6 +80,7 @@ import qualified Stream import Data.List import Data.Maybe import Control.Exception +import Control.Applicative (Applicative(..)) import Control.Monad import System.IO @@ -873,6 +874,13 @@ cmmToCmm dflags this_mod (CmmProc info lbl live graph) newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #)) +instance Functor CmmOptM where + fmap = liftM + +instance Applicative CmmOptM where + pure = return + (<*>) = ap + instance Monad CmmOptM where return x = CmmOptM $ \_ _ imports -> (# x, imports #) (CmmOptM f) >>= g = diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index fec6805b4e..3ee3af2ea9 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -41,6 +41,9 @@ import Unique ( Unique ) import DynFlags import Module +import Control.Monad ( liftM, ap ) +import Control.Applicative ( Applicative(..) ) + data NatM_State = NatM_State { natm_us :: UniqSupply, @@ -65,6 +68,13 @@ initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) } +instance Functor NatM where + fmap = liftM + +instance Applicative NatM where + pure = return + (<*>) = ap + instance Monad NatM where (>>=) = thenNat return = returnNat diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index a608a947e7..dc499c9c1f 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -40,13 +40,21 @@ import DynFlags import Unique import UniqSupply +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) + -- | The register allocator monad type. newtype RegM freeRegs a = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } +instance Functor (RegM freeRegs) where + fmap = liftM + +instance Applicative (RegM freeRegs) where + pure = return + (<*>) = ap --- | The RegM Monad 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 #) diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 64a9f9b912..3b895d8125 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -49,6 +49,7 @@ import Platform import Util import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) +import Control.Applicative ( Applicative(..), Alternative(..) ) import Control.Monad import Data.Bits as Bits import qualified Data.ByteString as BS @@ -540,6 +541,13 @@ mkBasicRule op_name n_args rm newtype RuleM r = RuleM { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r } +instance Functor RuleM where + fmap = liftM + +instance Applicative RuleM where + pure = return + (<*>) = ap + instance Monad RuleM where return x = RuleM $ \_ _ _ -> Just x RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of @@ -547,6 +555,10 @@ instance Monad RuleM where Just r -> runRuleM (g r) dflags iu e fail _ = mzero +instance Alternative RuleM where + empty = mzero + (<|>) = mplus + instance MonadPlus RuleM where mzero = RuleM $ \_ _ _ -> Nothing mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args -> diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index 5417ad491e..fdcf7447eb 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -36,6 +36,9 @@ import FastString import SrcLoc import Util +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) + stgMassageForProfiling :: DynFlags @@ -220,6 +223,13 @@ newtype MassageM result -> (CollectedCCs, result) } +instance Functor MassageM where + fmap = liftM + +instance Applicative MassageM where + pure = return + (<*>) = ap + instance Monad MassageM where return x = MassageM (\_ ccs -> (ccs, x)) (>>=) = thenMM diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index e7cecf8f3f..9488f91ddd 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -44,7 +44,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) import HsSyn import TcRnMonad -import TcHsSyn ( hsOverLitName ) +import TcHsSyn ( hsOverLitName ) import RnEnv import RnTypes import DynFlags @@ -54,14 +54,14 @@ import NameSet import RdrName import BasicTypes import Util -import ListSetOps ( removeDups ) +import ListSetOps ( removeDups ) import Outputable import SrcLoc import FastString -import Literal ( inCharRange ) -import TysWiredIn ( nilDataCon ) -import DataCon ( dataConName ) -import Control.Monad ( when ) +import Literal ( inCharRange ) +import TysWiredIn ( nilDataCon ) +import DataCon ( dataConName ) +import Control.Monad ( when, liftM, ap ) import Data.Ratio \end{code} @@ -98,6 +98,13 @@ newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars) } -- See Note [CpsRn monad] +instance Functor CpsRn where + fmap = liftM + +instance Applicative CpsRn where + pure = return + (<*>) = ap + instance Monad CpsRn where return x = CpsRn (\k -> k x) (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k)) diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 0af8201170..548e04c9cf 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -106,6 +106,7 @@ 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 Prelude hiding ( read ) @@ -819,10 +820,14 @@ instance Monad CoreM where let w = w1 `plusWriter` w2 -- forcing w before returning avoids a space leak (Trac #7702) return $ seq w (y, s'', w) -instance Applicative CoreM where +instance A.Applicative CoreM where pure = return (<*>) = ap +instance MonadPlus IO => A.Alternative CoreM where + empty = mzero + (<|>) = mplus + -- For use if the user has imported Control.Monad.Error from MTL -- Requires UndecidableInstances instance MonadPlus IO => MonadPlus CoreM where diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 4c3c72d301..6a908836e2 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -29,7 +29,7 @@ import CoreMonad import Outputable import FastString import MonadUtils -import Control.Monad ( when ) +import Control.Monad ( when, liftM, ap ) \end{code} %************************************************************************ @@ -97,6 +97,14 @@ computeMaxTicks dflags size {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-} + +instance Functor SimplM where + fmap = liftM + +instance Applicative SimplM where + pure = return + (<*>) = ap + instance Monad SimplM where (>>) = thenSmpl_ (>>=) = thenSmpl diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index a175e5ed4b..b83cecf03c 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -34,6 +34,7 @@ import Outputable import FastString import State +import Control.Applicative (Applicative(..)) import Control.Monad import Data.Map (Map) import qualified Data.Map as Map @@ -1867,6 +1868,13 @@ data SpecState = SpecState { spec_dflags :: DynFlags } +instance Functor SpecM where + fmap = liftM + +instance Applicative SpecM where + pure = return + (<*>) = ap + instance Monad SpecM where SpecM x >>= f = SpecM $ do y <- x case f y of diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index c87de4e65f..80b81a68e4 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -44,6 +44,8 @@ import ForeignCall import Demand ( isSingleUsed ) import PrimOp ( PrimCall(..) ) +import Control.Monad (liftM, ap) + -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ -- @@ -982,6 +984,13 @@ thenLne :: LneM a -> (a -> LneM b) -> LneM b thenLne m k = LneM $ \env lvs_cont -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont +instance Functor LneM where + fmap = liftM + +instance Applicative LneM where + pure = return + (<*>) = ap + instance Monad LneM where return = returnLne (>>=) = thenLne diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 3509a83849..04349db3df 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -25,6 +25,7 @@ import Util import SrcLoc import Outputable import FastString +import Control.Applicative ( Applicative(..) ) import Control.Monad import Data.Function @@ -319,6 +320,13 @@ initL (LintM m) Just (vcat (punctuate blankLine (bagToList errs))) } +instance Functor LintM where + fmap = liftM + +instance Applicative LintM where + pure = return + (<*>) = ap + instance Monad LintM where return a = LintM $ \_loc _scope errs -> (a, errs) (>>=) = thenL diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 5091cab802..4f3971b7d7 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -48,6 +48,7 @@ import UniqSet import Util import Maybes import Data.List +import Control.Applicative (Applicative(..)) import Control.Monad \end{code} @@ -772,6 +773,14 @@ data RoleInferenceInfo = RII { var_ns :: VarPositions newtype RoleM a = RM { unRM :: Maybe RoleInferenceInfo -> RoleInferenceState -> (a, RoleInferenceState) } + +instance Functor RoleM where + fmap = liftM + +instance Applicative RoleM where + pure = return + (<*>) = ap + instance Monad RoleM where return x = RM $ \_ state -> (x, state) a >>= f = RM $ \m_info state -> let (a', state') = unRM a m_info state in diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index af67808044..fddd1607c3 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -182,6 +182,8 @@ import Outputable import FastString import Data.IORef +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) \end{code} %************************************************************************ @@ -1048,6 +1050,13 @@ data OccCheckResult a | OC_NonTyVar | OC_Occurs +instance Functor OccCheckResult where + fmap = liftM + +instance Applicative OccCheckResult where + pure = return + (<*>) = ap + instance Monad OccCheckResult where return x = OC_OK x OC_OK x >>= k = k x diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 4b5d2ea63d..70170884dc 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -39,6 +39,9 @@ import Type import TyCon import TypeRep import Util + +import Control.Monad (liftM, ap) +import Control.Applicative (Applicative(..)) \end{code} @@ -649,6 +652,13 @@ data BindFlag newtype UM a = UM { unUM :: (TyVar -> BindFlag) -> UnifyResultM a } +instance Functor UM where + fmap = liftM + +instance Applicative UM where + pure = return + (<*>) = ap + instance Monad UM where return a = UM (\_tvs -> Unifiable a) fail _ = UM (\_tvs -> SurelyApart) -- failed pattern match diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 583e875903..04c11cf531 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -42,6 +42,7 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( fixIO ) import Control.Monad import MonadUtils +import Control.Applicative (Alternative(..)) ---------------------------------------------------------------------- -- Defining the monad type @@ -150,9 +151,13 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) ---------------------------------------------------------------------- --- MonadPlus +-- Alternative/MonadPlus ---------------------------------------------------------------------- +instance MonadPlus IO => Alternative (IOEnv env) where + empty = mzero + (<|>) = mplus + -- For use if the user has imported Control.Monad.Error from MTL -- Requires UndecidableInstances instance MonadPlus IO => MonadPlus (IOEnv env) where diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index a3fe632493..54e7e0c984 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -46,6 +46,7 @@ import Data.IORef import System.CPUTime import System.Environment import System.IO +import Control.Applicative (Applicative(..)) import Control.Monad import GHC.Exts @@ -168,13 +169,17 @@ reifyGHCi f = GHCi f' startGHCi :: GHCi a -> GHCiState -> Ghc a startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref +instance Functor GHCi where + fmap = liftM + +instance Applicative GHCi where + pure = return + (<*>) = ap + instance Monad GHCi where (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s return a = GHCi $ \_ -> return a -instance Functor GHCi where - fmap f m = m >>= return . f - getGHCiState :: GHCi GHCiState getGHCiState = GHCi $ \r -> liftIO $ readIORef r setGHCiState :: GHCiState -> GHCi () diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 41ed265f4b..30acbe2eb8 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -34,6 +34,7 @@ import Data.Maybe import Data.Char ( isSpace, toLower ) import Data.Ord (comparing) +import Control.Applicative (Applicative(..)) import Control.Monad import System.Directory ( doesDirectoryExist, getDirectoryContents, doesFileExist, renameFile, removeFile, @@ -1303,6 +1304,13 @@ type ValidateWarning = String newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } +instance Functor Validate where + fmap = liftM + +instance Applicative Validate where + pure = return + (<*>) = ap + instance Monad Validate where return a = V $ return (a, [], []) m >>= k = V $ do |