diff options
23 files changed, 200 insertions, 29 deletions
diff --git a/testsuite/tests/codeGen/should_compile/jmp_tbl.hs b/testsuite/tests/codeGen/should_compile/jmp_tbl.hs index 673efc849d..2af97d1d6c 100644 --- a/testsuite/tests/codeGen/should_compile/jmp_tbl.hs +++ b/testsuite/tests/codeGen/should_compile/jmp_tbl.hs @@ -50,6 +50,9 @@ module DriverPipeline (compileFile) where import Control.Exception +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + data Phase = Unlit () | Ccpp @@ -75,6 +78,13 @@ data PipeState = PipeState { newtype CompPipeline a = P { unP :: PipeState -> IO (PipeState, a) } +instance Functor CompPipeline where + fmap = liftM + +instance Applicative CompPipeline where + pure = return + (<*>) = ap + instance Monad CompPipeline where return a = P $ \state -> return (state, a) P m >>= k = P $ \state -> do (state',a) <- m state diff --git a/testsuite/tests/cpranal/should_compile/Cpr001_imp.hs b/testsuite/tests/cpranal/should_compile/Cpr001_imp.hs index 5b2586127b..22352ead05 100644 --- a/testsuite/tests/cpranal/should_compile/Cpr001_imp.hs +++ b/testsuite/tests/cpranal/should_compile/Cpr001_imp.hs @@ -2,6 +2,9 @@ module Cpr001_imp where +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + data MS = MS { instr :: String , pc :: Int , mem :: String @@ -18,6 +21,13 @@ newtype StateTrans s a = ST ( s -> (s, Maybe a)) -- as it is and Nothing is returned as value -- else execution continues +instance Functor (StateTrans s) where + fmap = liftM + +instance Applicative (StateTrans s) where + pure = return + (<*>) = ap + instance Monad (StateTrans s) where (ST p) >>= k = ST (\s0 -> let diff --git a/testsuite/tests/deriving/should_compile/drv020.hs b/testsuite/tests/deriving/should_compile/drv020.hs index 8794b745e5..9956407fbd 100644 --- a/testsuite/tests/deriving/should_compile/drv020.hs +++ b/testsuite/tests/deriving/should_compile/drv020.hs @@ -5,6 +5,9 @@ -- one-argument newtype defined in the same module module ShouldSucceed where +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + -- library stuff class Monad m => MonadState s m | m -> s where @@ -15,6 +18,13 @@ newtype State s a = State { runState :: (s -> (a, s)) } +instance Functor (State s) where + fmap = liftM + +instance Applicative (State s) where + pure = return + (<*>) = ap + instance Monad (State s) where return a = State $ \s -> (a, s) m >>= k = State $ \s -> let @@ -28,7 +38,7 @@ instance MonadState s (State s) where -- test code newtype Foo a = MkFoo (State Int a) - deriving (Monad, MonadState Int) + deriving (Functor, Applicative, Monad, MonadState Int) f :: Foo Int f = get diff --git a/testsuite/tests/ffi/should_compile/ffi-deriv1.hs b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs index 94d0df2fa4..1e5d27a0b6 100644 --- a/testsuite/tests/ffi/should_compile/ffi-deriv1.hs +++ b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- Tests newtype unwrapping for the IO monad itself
-- Notice the RenderM monad, which is used in the
@@ -6,8 +6,10 @@ module ShouldCompile where
+import Control.Applicative (Applicative)
+
import Foreign.Ptr
-newtype RenderM a = RenderM (IO a) deriving (Functor, Monad)
+newtype RenderM a = RenderM (IO a) deriving (Functor, Applicative, Monad)
type RenderCallback = Int -> Int -> RenderM ()
diff --git a/testsuite/tests/gadt/gadt16.hs b/testsuite/tests/gadt/gadt16.hs index 133c833903..194ed5d6ea 100644 --- a/testsuite/tests/gadt/gadt16.hs +++ b/testsuite/tests/gadt/gadt16.hs @@ -14,6 +14,9 @@ module Sample where +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + data Safe data MayFail @@ -23,6 +26,13 @@ data Result s a where newtype M s a = M { unM :: IO (Result s a) } +instance Functor (M s) where + fmap = liftM + +instance Applicative (M s) where + pure = return + (<*>) = ap + instance Monad (M s) where return x = M (return (Ok x)) diff --git a/testsuite/tests/gadt/nbe.hs b/testsuite/tests/gadt/nbe.hs index 82b7b83259..60141291fc 100644 --- a/testsuite/tests/gadt/nbe.hs +++ b/testsuite/tests/gadt/nbe.hs @@ -2,6 +2,9 @@ module Main where +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + -- abstract syntax ------------------------------------------------------------- data Ty t where Bool :: Ty Bool @@ -87,6 +90,13 @@ data Tree a = Val a | Choice (Tree a) (Tree a) -- Val :: a -> Tree a Z -- Choice :: Tree a n -> Tree a n -> Tree a (S n) +instance Functor Tree where + fmap = liftM + +instance Applicative Tree where + pure = return + (<*>) = ap + instance Monad Tree where return x = Val x (Val a) >>= f = f a diff --git a/testsuite/tests/ghci.debugger/HappyTest.hs b/testsuite/tests/ghci.debugger/HappyTest.hs index ad444f7161..7f13a93596 100644 --- a/testsuite/tests/ghci.debugger/HappyTest.hs +++ b/testsuite/tests/ghci.debugger/HappyTest.hs @@ -6,6 +6,9 @@ import System.IO import System.IO.Unsafe import Debug.Trace +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + -- parser produced by Happy Version 1.16 data HappyAbsSyn @@ -166,6 +169,13 @@ newtype HappyIdentity a = HappyIdentity a happyIdentity = HappyIdentity happyRunIdentity (HappyIdentity a) = a +instance Functor HappyIdentity where + fmap = liftM + +instance Applicative HappyIdentity where + pure = return + (<*>) = ap + instance Monad HappyIdentity where return = HappyIdentity (HappyIdentity p) >>= q = q p diff --git a/testsuite/tests/ghci.debugger/scripts/print020.stdout b/testsuite/tests/ghci.debugger/scripts/print020.stdout index 452fd064ae..80e9473911 100644 --- a/testsuite/tests/ghci.debugger/scripts/print020.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print020.stdout @@ -1,5 +1,5 @@ -Breakpoint 0 activated at ../HappyTest.hs:(216,1)-(227,35) -Stopped at ../HappyTest.hs:(216,1)-(227,35) +Breakpoint 0 activated at ../HappyTest.hs:(226,1)-(237,35) +Stopped at ../HappyTest.hs:(226,1)-(237,35) _result :: [Token] = _ *** Ignoring breakpoint *** Ignoring breakpoint diff --git a/testsuite/tests/indexed-types/should_compile/DerivingNewType.hs b/testsuite/tests/indexed-types/should_compile/DerivingNewType.hs index 65f3b8520d..5a90aa6757 100644 --- a/testsuite/tests/indexed-types/should_compile/DerivingNewType.hs +++ b/testsuite/tests/indexed-types/should_compile/DerivingNewType.hs @@ -2,6 +2,8 @@ module ShouldCompile where +import Control.Applicative (Applicative) + data family S a newtype instance S Int = S Int @@ -10,5 +12,5 @@ newtype instance S Int = S Int data family S2 a b newtype instance S2 Int b = S2 (IO b) - deriving Monad + deriving (Functor, Applicative, Monad) diff --git a/testsuite/tests/mdo/should_fail/mdofail004.hs b/testsuite/tests/mdo/should_fail/mdofail004.hs index 37cd757312..929785423c 100644 --- a/testsuite/tests/mdo/should_fail/mdofail004.hs +++ b/testsuite/tests/mdo/should_fail/mdofail004.hs @@ -10,8 +10,18 @@ module Main (main) where import Control.Monad.Fix +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + data X a = X a deriving Show +instance Functor X where + fmap = liftM + +instance Applicative X where + pure = return + (<*>) = ap + instance Monad X where return = X (X a) >>= f = f a diff --git a/testsuite/tests/rebindable/rebindable9.hs b/testsuite/tests/rebindable/rebindable9.hs index 081e22c46f..120a93a3a4 100644 --- a/testsuite/tests/rebindable/rebindable9.hs +++ b/testsuite/tests/rebindable/rebindable9.hs @@ -7,8 +7,18 @@ module Foo where import qualified Prelude import Prelude hiding (Monad(..)) +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + newtype Identity a = Identity { runIdentity :: a } +instance Prelude.Functor Identity where + fmap = liftM + +instance Applicative Identity where + pure = Prelude.return + (<*>) = ap + instance Prelude.Monad Identity where return a = Identity a m >>= k = k (runIdentity m) diff --git a/testsuite/tests/rename/should_compile/T1954.hs b/testsuite/tests/rename/should_compile/T1954.hs index 07bfa3a3e8..dfcb551830 100644 --- a/testsuite/tests/rename/should_compile/T1954.hs +++ b/testsuite/tests/rename/should_compile/T1954.hs @@ -2,5 +2,7 @@ {-# OPTIONS_GHC -Wall -Werror #-} module Bug(P) where -newtype P a = P (IO a) deriving Monad +import Control.Applicative (Applicative) + +newtype P a = P (IO a) deriving (Functor, Applicative, Monad) diff --git a/testsuite/tests/rename/should_compile/T7145b.hs b/testsuite/tests/rename/should_compile/T7145b.hs index f34ea4ded6..b9dcef7085 100644 --- a/testsuite/tests/rename/should_compile/T7145b.hs +++ b/testsuite/tests/rename/should_compile/T7145b.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module T7145b ( A.Applicative(pure) ) where import qualified Control.Applicative as A diff --git a/testsuite/tests/rename/should_compile/T7145b.stderr b/testsuite/tests/rename/should_compile/T7145b.stderr index f24d02954b..bc3d1865f8 100644 --- a/testsuite/tests/rename/should_compile/T7145b.stderr +++ b/testsuite/tests/rename/should_compile/T7145b.stderr @@ -1,2 +1,2 @@ -T7145b.hs:6:1: Warning: Defined but not used: ‛pure’ +T7145b.hs:8:1: Warning: Defined but not used: ‛pure’ diff --git a/testsuite/tests/simplCore/prog002/Simpl009Help.hs b/testsuite/tests/simplCore/prog002/Simpl009Help.hs index ac75943016..e4c6df351e 100644 --- a/testsuite/tests/simplCore/prog002/Simpl009Help.hs +++ b/testsuite/tests/simplCore/prog002/Simpl009Help.hs @@ -4,6 +4,7 @@ module Simpl009Help where +import Control.Applicative (Applicative(..), Alternative(empty, (<|>))) import Control.Monad newtype Parser s a @@ -14,6 +15,13 @@ data P s res | Fail [String] [String] | Result res (P s res) +instance Functor (Parser s) where + fmap = liftM + +instance Applicative (Parser s) where + pure = return + (<*>) = ap + instance Monad (Parser s) where return a = Parser (\fut -> fut a) @@ -23,6 +31,10 @@ instance Monad (Parser s) where fail s = Parser (\fut exp -> Fail exp [s]) +instance Alternative (Parser s) where + empty = mzero + (<|>) = mplus + instance MonadPlus (Parser s) where mplus = error "urk" mzero = Parser (\fut exp -> Fail exp []) diff --git a/testsuite/tests/simplCore/should_compile/EvalTest.hs b/testsuite/tests/simplCore/should_compile/EvalTest.hs index 8fce496ab3..8ce80ae4c1 100644 --- a/testsuite/tests/simplCore/should_compile/EvalTest.hs +++ b/testsuite/tests/simplCore/should_compile/EvalTest.hs @@ -11,8 +11,18 @@ module EvalTest where import GHC.Conc +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + data Eval a = Done a +instance Functor Eval where + fmap = liftM + +instance Applicative Eval where + pure = return + (<*>) = ap + instance Monad Eval where return x = Done x Done x >>= k = k x -- Note: pattern 'Done x' makes '>>=' strict diff --git a/testsuite/tests/simplCore/should_compile/T3831.hs b/testsuite/tests/simplCore/should_compile/T3831.hs index 55b4d08f3a..50b1e3567b 100644 --- a/testsuite/tests/simplCore/should_compile/T3831.hs +++ b/testsuite/tests/simplCore/should_compile/T3831.hs @@ -6,6 +6,7 @@ module T3831(setAttributes) where import Data.Monoid +import Control.Applicative (Applicative(..), Alternative(empty, (<|>))) import Control.Monad class (Monoid s, OutputCap s) => TermStr s @@ -17,13 +18,13 @@ class OutputCap f where instance OutputCap [Char] where instance (Enum p, OutputCap f) => OutputCap (p -> f) where -instance MonadPlus Capability where - mzero = Capability (const $ return Nothing) - Capability f `mplus` Capability g = Capability $ \t -> do - mx <- f t - case mx of - Nothing -> g t - _ -> return mx + +instance Functor Capability where + fmap = liftM + +instance Applicative Capability where + pure = return + (<*>) = ap instance Monad Capability where return = Capability . const . return . Just @@ -33,6 +34,18 @@ instance Monad Capability where Nothing -> return Nothing Just x -> let Capability g' = g x in g' t +instance Alternative Capability where + empty = mzero + (<|>) = mplus + +instance MonadPlus Capability where + mzero = Capability (const $ return Nothing) + Capability f `mplus` Capability g = Capability $ \t -> do + mx <- f t + case mx of + Nothing -> g t + _ -> return mx + newtype Capability a = Capability (() -> IO (Maybe a)) tiGetOutput1 :: forall f . OutputCap f => String -> Capability f diff --git a/testsuite/tests/simplCore/should_compile/T4203.hs b/testsuite/tests/simplCore/should_compile/T4203.hs index 89591f037d..3bf9259544 100644 --- a/testsuite/tests/simplCore/should_compile/T4203.hs +++ b/testsuite/tests/simplCore/should_compile/T4203.hs @@ -4,6 +4,8 @@ module T4203 where +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) newtype NonNegative a = NonNegative a deriving (Eq, Num, Show) @@ -26,6 +28,13 @@ instance Arbitrary EmptyStackSet where newtype Gen a = Gen a +instance Functor Gen where + fmap = liftM + +instance Applicative Gen where + pure = return + (<*>) = ap + instance Monad Gen where return a = Gen a Gen m >>= k = Gen (let Gen m' = k m in m') diff --git a/testsuite/tests/typecheck/should_compile/T3955.hs b/testsuite/tests/typecheck/should_compile/T3955.hs index 921753b80a..220c4e7c25 100644 --- a/testsuite/tests/typecheck/should_compile/T3955.hs +++ b/testsuite/tests/typecheck/should_compile/T3955.hs @@ -5,9 +5,19 @@ module T3955 where +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + class (Monad m) => MonadReader r m newtype Reader r a = Reader { runReader :: r -> a } +instance Functor (Reader r) where + fmap = liftM + +instance Applicative (Reader r) where + pure = return + (<*>) = ap + instance Monad (Reader r) where (>>=) = error "urk" return = error "urk" @@ -15,7 +25,7 @@ instance Monad (Reader r) where instance MonadReader r (Reader r) newtype T a x = T (Reader a x) - deriving (Monad, MonadReader a) + deriving (Functor, Applicative, Monad, MonadReader a) {- [1 of 1] Compiling Main ( bug.hs, interpreted ) diff --git a/testsuite/tests/typecheck/should_compile/T4952.hs b/testsuite/tests/typecheck/should_compile/T4952.hs index b0d2fba794..42d6258c2f 100644 --- a/testsuite/tests/typecheck/should_compile/T4952.hs +++ b/testsuite/tests/typecheck/should_compile/T4952.hs @@ -6,6 +6,8 @@ module Storage.Hashed.Monad () where +import Control.Applicative (Applicative(..)) + class Monad m => TreeRO m where withDirectory :: (MonadError e m) => Int -> m a -> m a expandTo :: (MonadError e m) => Int -> m Int @@ -18,6 +20,13 @@ instance (Monad m, MonadError e m) => TreeRO (M m) where data M (m :: * -> *) a +instance Functor (M m) where + fmap = undefined + +instance Applicative (M m) where + pure = undefined + (<*>) = undefined + instance Monad m => Monad (M m) where (>>=) = undefined return = undefined diff --git a/testsuite/tests/typecheck/should_compile/Tc239_Help.hs b/testsuite/tests/typecheck/should_compile/Tc239_Help.hs index c72acdfb11..4f39612e4e 100644 --- a/testsuite/tests/typecheck/should_compile/Tc239_Help.hs +++ b/testsuite/tests/typecheck/should_compile/Tc239_Help.hs @@ -1,13 +1,23 @@ -module Tc239_Help ( WrapIO, WrapIO2 ) where
-
-newtype WrapIO e a = MkWrapIO { unwrap :: IO a }
-
-type WrapIO2 a = WrapIO String a
-
-instance Monad (WrapIO e) where
- return x = MkWrapIO (return x)
-
- m >>= f = MkWrapIO (do x <- unwrap m
- unwrap (f x) )
-
+module Tc239_Help ( WrapIO, WrapIO2 ) where + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +newtype WrapIO e a = MkWrapIO { unwrap :: IO a } + +type WrapIO2 a = WrapIO String a + +instance Functor (WrapIO e) where + fmap = liftM + +instance Applicative (WrapIO e) where + pure = return + (<*>) = ap + +instance Monad (WrapIO e) where + return x = MkWrapIO (return x) + + m >>= f = MkWrapIO (do x <- unwrap m + unwrap (f x) ) + fail str = error str
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/tc093.hs b/testsuite/tests/typecheck/should_compile/tc093.hs index c834428b20..c0ae576e95 100644 --- a/testsuite/tests/typecheck/should_compile/tc093.hs +++ b/testsuite/tests/typecheck/should_compile/tc093.hs @@ -1,5 +1,8 @@ module ShouldSucceed where +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + data State c a = State (c -> (a,c)) unState :: State c a -> (c -> (a,c)) @@ -13,6 +16,13 @@ bindState m k = State (\s0 -> let (a,s1) = (unState m) s0 (b,s2) = (unState (k a)) s1 in (b,s2)) +instance Eq c => Functor (State c) where + fmap = liftM + +instance Eq c => Applicative (State c) where + pure = return + (<*>) = ap + instance Eq c => Monad (State c) where return = unitState (>>=) = bindState diff --git a/testsuite/tests/typecheck/should_compile/tc258.hs b/testsuite/tests/typecheck/should_compile/tc258.hs index 54a3e637be..353ec94c43 100644 --- a/testsuite/tests/typecheck/should_compile/tc258.hs +++ b/testsuite/tests/typecheck/should_compile/tc258.hs @@ -12,4 +12,4 @@ class MyFunctor f where class MyFunctor ap => MyApplicative ap where type ApplicativeCtxt ap a :: Constraint type ApplicativeCtxt ap a = FunctorCtxt ap a - (<*>) :: (ApplicativeCtxt ap a, ApplicativeCtxt ap b) => ap (a -> b) -> ap a -> ap b + (<***>) :: (ApplicativeCtxt ap a, ApplicativeCtxt ap b) => ap (a -> b) -> ap a -> ap b |