Commit b20cf4ec authored by Austin Seipp's avatar Austin Seipp
Browse files

Fix AMP warnings.


Authored-by: quchen's avatarDavid Luposchainsky <dluposchainsky@gmail.com>
Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent 1ef941a8
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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_
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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 =
......
......@@ -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
......
......@@ -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 #)
......
......@@ -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 ->
......
......@@ -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
......
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