diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 8383f0624..74615dc98 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -201,11 +201,11 @@ instance Fail.MonadFail CnvMonad where fail = bug instance Applicative CnvMonad where - pure = return + pure a = CM (\gr c s -> c a s) (<*>) = ap instance Monad CnvMonad where - return a = CM (\gr c s -> c a s) + return = pure CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s) instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index ed3a20ce0..0e76c3205 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -644,7 +644,7 @@ data TcResult a newtype TcM a = TcM {unTcM :: MetaStore -> [Message] -> TcResult a} instance Monad TcM where - return x = TcM (\ms msgs -> TcOk x ms msgs) + return = pure f >>= g = TcM (\ms msgs -> case unTcM f ms msgs of TcOk x ms msgs -> unTcM (g x) ms msgs TcFail msgs -> TcFail msgs) @@ -659,7 +659,7 @@ instance Fail.MonadFail TcM where instance Applicative TcM where - pure = return + pure x = TcM (\ms msgs -> TcOk x ms msgs) (<*>) = ap instance Functor TcM where diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index ceb1b99b5..11f806175 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -238,12 +238,12 @@ runCO (CO m) = do (o,x) <- m instance Functor m => Functor (CollectOutput m) where fmap f (CO m) = CO (fmap (fmap f) m) -instance (Functor m,Monad m) => Applicative (CollectOutput m) where - pure = return +instance (Functor m,Monad m) => Applicative (CollectOutput m) where + pure x = CO (return (return (),x)) (<*>) = ap instance Monad m => Monad (CollectOutput m) where - return x = CO (return (return (),x)) + return = pure CO m >>= f = CO $ do (o1,x) <- m let CO m2 = f x (o2,y) <- m2 diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs index 970de5c06..69bc2c29b 100644 --- a/src/compiler/GF/Data/BacktrackM.hs +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -64,11 +64,11 @@ finalStates :: BacktrackM s () -> s -> [s] finalStates bm = map fst . runBM bm instance Applicative (BacktrackM s) where - pure = return + pure a = BM (\c s b -> c a s b) (<*>) = ap instance Monad (BacktrackM s) where - return a = BM (\c s b -> c a s b) + return = pure BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) where unBM (BM m) = m diff --git a/src/compiler/GF/Data/ErrM.hs b/src/compiler/GF/Data/ErrM.hs index 288c61919..133a49b73 100644 --- a/src/compiler/GF/Data/ErrM.hs +++ b/src/compiler/GF/Data/ErrM.hs @@ -34,7 +34,7 @@ fromErr :: a -> Err a -> a fromErr a = err (const a) id instance Monad Err where - return = Ok + return = pure Ok a >>= f = f a Bad s >>= f = Bad s @@ -54,7 +54,7 @@ instance Functor Err where fmap f (Bad s) = Bad s instance Applicative Err where - pure = return + pure = Ok (<*>) = ap -- | added by KJ diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index b3d271ddd..248d091a1 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -283,11 +283,11 @@ instance Functor P where fmap = liftA instance Applicative P where - pure = return + pure a = a `seq` (P $ \s -> POk s a) (<*>) = ap instance Monad P where - return a = a `seq` (P $ \s -> POk s a) + return = pure (P m) >>= k = P $ \ s -> case m s of POk s a -> unP (k a) s PFailed posn err -> PFailed posn err diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index a5ff7148a..1dd26dd5c 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -48,7 +48,7 @@ newtype Check a instance Functor Check where fmap = liftM instance Monad Check where - return x = Check $ \{-ctxt-} ws -> (ws,Success x) + return = pure f >>= g = Check $ \{-ctxt-} ws -> case unCheck f {-ctxt-} ws of (ws,Success x) -> unCheck (g x) {-ctxt-} ws @@ -58,7 +58,7 @@ instance Fail.MonadFail Check where fail = raise instance Applicative Check where - pure = return + pure x = Check $ \{-ctxt-} ws -> (ws,Success x) (<*>) = ap instance ErrorMonad Check where diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 906f39345..7b5a7dac6 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -52,11 +52,11 @@ newtype SIO a = SIO {unS::PutStr->IO a} instance Functor SIO where fmap = liftM instance Applicative SIO where - pure = return + pure x = SIO (const (pure x)) (<*>) = ap instance Monad SIO where - return x = SIO (const (return x)) + return = pure SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h instance Fail.MonadFail SIO where diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs index 8dc46f816..e22fa4a4c 100644 --- a/src/runtime/haskell/Data/Binary/Builder.hs +++ b/src/runtime/haskell/Data/Binary/Builder.hs @@ -114,7 +114,7 @@ instance Semigroup Builder where instance Monoid Builder where mempty = empty {-# INLINE mempty #-} - mappend = append + mappend = (<>) {-# INLINE mappend #-} ------------------------------------------------------------------------ diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs index a33c5c5a3..ec6309fae 100644 --- a/src/runtime/haskell/Data/Binary/Get.hs +++ b/src/runtime/haskell/Data/Binary/Get.hs @@ -127,11 +127,11 @@ instance Functor Get where {-# INLINE fmap #-} instance Applicative Get where - pure = return + pure a = Get (\s -> (a, s)) (<*>) = ap instance Monad Get where - return a = Get (\s -> (a, s)) + return = pure {-# INLINE return #-} m >>= k = Get (\s -> case unGet m s of diff --git a/src/runtime/haskell/Data/Binary/Put.hs b/src/runtime/haskell/Data/Binary/Put.hs index 189cf806f..05d23fba6 100644 --- a/src/runtime/haskell/Data/Binary/Put.hs +++ b/src/runtime/haskell/Data/Binary/Put.hs @@ -77,15 +77,20 @@ instance Functor PutM where {-# INLINE fmap #-} instance Applicative PutM where - pure = return + pure a = Put $ PairS a mempty m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k in PairS (f x) (w `mappend` w') + m *> k = Put $ + let PairS _ w = unPut m + PairS b w' = unPut k + in PairS b (w `mappend` w') + {-# INLINE (*>) #-} -- Standard Writer monad, with aggressive inlining instance Monad PutM where - return a = Put $ PairS a mempty + return = pure {-# INLINE return #-} m >>= k = Put $ @@ -94,10 +99,7 @@ instance Monad PutM where in PairS b (w `mappend` w') {-# INLINE (>>=) #-} - m >> k = Put $ - let PairS _ w = unPut m - PairS b w' = unPut k - in PairS b (w `mappend` w') + (>>) = (*>) {-# INLINE (>>) #-} tell :: Builder -> Put diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 82bd47b7a..f02986fc0 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -94,11 +94,11 @@ class Selector s where select :: CId -> Scope -> Maybe Int -> TcM s (Expr,TType) instance Applicative (TcM s) where - pure = return + pure x = TcM (\abstr k h -> k x) (<*>) = ap instance Monad (TcM s) where - return x = TcM (\abstr k h -> k x) + return = pure f >>= g = TcM (\abstr k h -> unTcM f abstr (\x -> unTcM (g x) abstr k h) h) instance Selector s => Alternative (TcM s) where