diff options
Diffstat (limited to 'testsuite/tests/rebindable')
29 files changed, 1719 insertions, 0 deletions
diff --git a/testsuite/tests/rebindable/DoParamM.hs b/testsuite/tests/rebindable/DoParamM.hs new file mode 100644 index 0000000000..95ff235cdd --- /dev/null +++ b/testsuite/tests/rebindable/DoParamM.hs @@ -0,0 +1,303 @@ +{-# OPTIONS -XRebindableSyntax #-} +-- Haskell98! + +-- Tests of the do-notation for the parameterized monads +-- We demonstrate a variable-type state `monadic' transformer +-- and its phantom-type-state relative to enforce the locking protocol +-- (a lock can be released only if it is being held, and acquired only +-- if it is not being held) +-- The tests are based on the code +-- http://okmij.org/ftp/Computation/monads.html#param-monad + +-- Please search for DO-NOT-YET + +module DoParamM where + +import Prelude (const, String, ($), (.), Maybe(..), + Int, fromInteger, succ, pred, fromEnum, toEnum, + (+), Char, (==), Bool(..), + IO, getLine, putStrLn, read, show) +import qualified Prelude +import qualified Control.Monad.State as State +import qualified Control.Monad.Identity as IdM + +-- A parameterized `monad' +class Monadish m where + return :: a -> m p p a + fail :: String -> m p p a + (>>=) :: m p q a -> (a -> m q r b) -> m p r b + +m1 >> m2 = m1 >>= (const m2) + +-- All regular monads are the instances of the parameterized monad + +newtype RegularM m p q a = RegularM{unRM :: m a} + +instance Prelude.Monad m => Monadish (RegularM m) where + return = RegularM . Prelude.return + fail = RegularM . Prelude.fail + m >>= f = RegularM ((Prelude.>>=) (unRM m) (unRM . f)) + +-- As a warm-up, we write the regular State computation, with the same +-- type of state throughout. We thus inject Monad.State into the +-- parameterized monad + +test1 = State.runState (unRM c) (0::Int) where + c = gget >>= (\v -> gput (succ v) >> return v) + gget :: (State.MonadState s m) => RegularM m s s s + gget = RegularM State.get + gput :: (State.MonadState s m) => s -> RegularM m s s () + gput = RegularM . State.put +-- (0,1) + +-- The same in the do-notation +test1_do = State.runState (unRM c) (0::Int) where + c = do + v <- gget + gput (succ v) + return v + gget :: (State.MonadState s m) => RegularM m s s s + gget = RegularM State.get + gput :: (State.MonadState s m) => s -> RegularM m s s () + gput = RegularM . State.put +-- (0,1) + + +-- Introduce the variable-type state (transformer) + +newtype VST m si so v = VST{runVST:: si -> m (so,v)} + +instance Prelude.Monad m => Monadish (VST m) where + return x = VST (\si -> Prelude.return (si,x)) + fail x = VST (\si -> Prelude.fail x) + m >>= f = VST (\si -> (Prelude.>>=) (runVST m si) + (\ (sm,x) -> runVST (f x) sm)) + +vsget :: Prelude.Monad m => VST m si si si +vsget = VST (\si -> Prelude.return (si,si)) +vsput :: Prelude.Monad m => so -> VST m si so () +vsput x = VST (\si -> Prelude.return (x,())) + + +-- Repeat test1 via VST: the type of the state is the same +vsm1 () = vsget >>= (\v -> vsput (succ v) >> return v) + +-- The same with the do-notation +vsm1_do () = do + v <- vsget + vsput (succ v) + return v + +{- + *DoParamM> :t vsm1 + vsm1 :: (Monadish (VST m), IdM.Monad m, Prelude.Enum si) => + () -> VST m si si si +-} + +test2 = IdM.runIdentity (runVST (vsm1 ()) (0::Int)) +-- (1,0) + +test2_do = IdM.runIdentity (runVST (vsm1_do ()) (0::Int)) +-- (1,0) + + +-- Now, we vary the type of the state, from Int to a Char +vsm2 () = vsget >>= (\v -> vsput ((toEnum (65+v))::Char) >> + vsget >>= \v' -> return (v,v')) + +{- + *DoParamM> :t vsm2 + vsm2 :: (Monadish (VST m), IdM.Monad m) => () -> VST m Int Char (Int, Char) +-} + +-- The same with the do-notation + -- the following does not yet work +vsm2_do () = do + v <- vsget + vsput ((toEnum (65+v))::Char) + v' <- vsget + return (v,v') + +test3 = IdM.runIdentity (runVST (vsm2 ()) (0::Int)) +-- ('A',(0,'A')) + +test3_do = IdM.runIdentity (runVST (vsm2_do ()) (0::Int)) +-- ('A',(0,'A')) + +{- The following is a deliberate error: + + DoParamM.hs:147:55: + Couldn't match expected type `Int' against inferred type `Char' + In the second argument of `(==)', namely `v'' + In the first argument of `return', namely `(v == v')' + In the expression: return (v == v') + +vsm3 () = vsget >>= (\v -> vsput ((toEnum (65+v))::Char) >> + vsget >>= \v' -> return (v==v')) + -} + + + -- The following too must report a type error -- the expression +-- return (v == v') must be flagged, rather than something else +vsm3_do () = do + v <- vsget + vsput ((toEnum (65+v))::Char) + v' <- vsget + return (v==v') + + + +-- Try polymorphic recursion, over the state. +-- crec1 invokes itself, and changes the type of the state from +-- some si to Bool. +crec1 :: (Prelude.Enum si, Prelude.Monad m) => VST m si si Int +crec1 = vsget >>= (\s1 -> case fromEnum s1 of + 0 -> return 0 + 1 -> vsput (pred s1) >> return 1 + _ -> vsput True >> + crec1 >>= (\v -> + (vsput s1 >> -- restore state type to si + return (v + 10)))) + +-- The same in the do-notation +crec1_do :: (Prelude.Enum si, Prelude.Monad m) => VST m si si Int +crec1_do = do + s1 <- vsget + case fromEnum s1 of + 0 -> return 0 + 1 -> do {vsput (pred s1); return 1} + _ -> do + vsput True + v <- crec1_do + vsput s1 -- restore state type to si + return (v + 10) + + +test4 = IdM.runIdentity (runVST crec1 'a') +-- ('a',11) + +test4_do = IdM.runIdentity (runVST crec1_do 'a') +-- ('a',11) + +-- Another example, to illustrate locking and static reasoning about +-- the locking state + +data Locked = Locked; data Unlocked = Unlocked +newtype LIO p q a = LIO{unLIO::IO a} + +instance Monadish LIO where + return = LIO . Prelude.return + m >>= f = LIO ((Prelude.>>=) (unLIO m) (unLIO . f)) + +lput :: String -> LIO p p () +lput = LIO . putStrLn +lget :: LIO p p String +lget = LIO getLine + +-- In the real program, the following will execute actions to acquire +-- or release the lock. Here, we just print out our intentions. +lock :: LIO Unlocked Locked () +lock = LIO (putStrLn "Lock") + +unlock :: LIO Locked Unlocked () +unlock = LIO (putStrLn "UnLock") + +-- We should start in unlocked state, and finish in the same state +runLIO :: LIO Unlocked Unlocked a -> IO a +runLIO = unLIO + +-- User code + +tlock1 = lget >>= (\l -> + return (read l) >>= (\x -> + lput (show (x+1)))) + +tlock1r = runLIO tlock1 + +-- the same in the do-notation +tlock1_do = do + l <- lget + let x = read l + lput (show (x+1)) + +{- + *VarStateM> :t tlock1 + tlock1 :: LIO p p () + Inferred type has the same input and output states and is polymorphic: + tlock1 does not affect the state of the lock. +-} + + +tlock2 = lget >>= (\l -> + lock >> ( + return (read l) >>= (\x -> + lput (show (x+1))))) + +tlock2_do = do + l <- lget + lock + let x = read l + lput (show (x+1)) + +{- + *VarStateM> :t tlock2 + tlock2 :: LIO Unlocked Locked () + +The inferred type says that the computation does the locking. +-} + +tlock3 = tlock2 >> unlock +tlock3r = runLIO tlock3 + +{- + *DoParamM> :t tlock3 + tlock3 :: LIO Unlocked Unlocked () +-} + +{- +*DoParamM> tlock3r +-- user input: 123 +Lock +124 +UnLock +-} + +tlock3_do = do {tlock2_do; unlock} +tlock3r_do = runLIO tlock3_do + + +-- An attempt to execute the following +-- tlock4 = tlock2 >> tlock2 + +{- + gives a type error: + Couldn't match expected type `Locked' + against inferred type `Unlocked' + Expected type: LIO Locked r b + Inferred type: LIO Unlocked Locked () + In the expression: tlock2 + In a lambda abstraction: \ _ -> tlock2 + +The error message correctly points out an error of acquiring an already +held lock. +-} + +-- The following too must be an error: with the SAME error message as above +tlock4_do = do {tlock2_do; tlock2_do} + +-- Similarly, the following gives a type error because of an attempt +-- to release a lock twice +-- tlock4' = tlock2 >> unlock >> unlock +{- +DoParamM.hs:298:30: + Couldn't match expected type `Unlocked' + against inferred type `Locked' + Expected type: LIO Unlocked r b + Inferred type: LIO Locked Unlocked () + In the second argument of `(>>)', namely `unlock' + In the expression: (tlock2 >> unlock) >> unlock +-} + + -- The following too must be an error: with the SAME error message as above +tlock4'_do = do {tlock2_do; unlock; unlock} + diff --git a/testsuite/tests/rebindable/DoParamM.stderr b/testsuite/tests/rebindable/DoParamM.stderr new file mode 100644 index 0000000000..7abfdd4b56 --- /dev/null +++ b/testsuite/tests/rebindable/DoParamM.stderr @@ -0,0 +1,25 @@ + +DoParamM.hs:146:25: + Couldn't match expected type `Int' with actual type `Char' + In the second argument of `(==)', namely `v'' + In the first argument of `return', namely `(v == v')' + In a stmt of a 'do' block: return (v == v') + +DoParamM.hs:286:28: + Couldn't match expected type `Locked' with actual type `Unlocked' + Expected type: LIO Locked r0 b0 + Actual type: LIO Unlocked Locked () + In a stmt of a 'do' block: tlock2_do + In the expression: + do { tlock2_do; + tlock2_do } + +DoParamM.hs:302:37: + Couldn't match expected type `Unlocked' with actual type `Locked' + Expected type: LIO Unlocked r0 b0 + Actual type: LIO Locked Unlocked () + In a stmt of a 'do' block: unlock + In the expression: + do { tlock2_do; + unlock; + unlock } diff --git a/testsuite/tests/rebindable/DoRestrictedM.hs b/testsuite/tests/rebindable/DoRestrictedM.hs new file mode 100644 index 0000000000..dea2b1ea03 --- /dev/null +++ b/testsuite/tests/rebindable/DoRestrictedM.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE RebindableSyntax, MultiParamTypeClasses, + FlexibleInstances #-} + +-- Tests of the do-notation for the restricted monads +-- We demonstrate that all ordinary monads are restricted monads, +-- and show the frequently requested implementation +-- of MonadPlus in terms of Data.Set. +-- +-- The tests are based on the code +-- http://okmij.org/ftp/Haskell/types.html#restricted-datatypes + +module DoRestrictedM where + +import Data.List +import Prelude (const, String, ($), (.), Maybe(..)) +import qualified Prelude +import qualified Data.Set as Set + +-- Defining the restricted monad +class MN2 m a where + return :: a -> m a + fail :: String -> m a + +class (MN2 m a, MN2 m b) => MN3 m a b where + (>>=) :: m a -> (a -> m b) -> m b + +m1 >> m2 = m1 >>= (const m2) + +-- All regular monads are the instances of the restricted monad + +newtype RegularM m a = RegularM{unRM :: m a} + +instance Prelude.Monad m => MN2 (RegularM m) a where + return = RegularM . Prelude.return + fail = RegularM . Prelude.fail + +instance Prelude.Monad m => MN3 (RegularM m) a b where + m >>= f = RegularM ((Prelude.>>=) (unRM m) (unRM . f)) + +-- We try to inject Maybe (as the regular monad) into Restricted Monad + +test1s () = return "a" >>= (\x -> return $ "b" ++ x) +test1f () = fail "" >>= (\x -> return $ "b" ++ x) + +-- the same with the do-notation + +test1s_do () = do + x <- return "a" + return $ "b" ++ x + + +{- +whose inferred type is + *DoRestrictedM> :t test1s + test1s :: (MN3 m [Prelude.Char] [Prelude.Char]) => () -> m [Prelude.Char] +-} + +test1sr :: Maybe String +test1sr = unRM $ test1s () +-- Just "ba" + +test1fr :: Maybe String +test1fr = unRM $ test1f () +-- Nothing + +test1sr_do :: Maybe String +test1sr_do = unRM $ test1s_do () +-- Just "ba" + +-- As often requested, we implement a MonadPlus `monad' +-- in terms of a Set. Set requires the Ord constraint. + +newtype SMPlus a = SMPlus{unSM:: Set.Set a} + +instance MN2 SMPlus a where + return = SMPlus . Set.singleton + fail x = SMPlus $ Set.empty + +instance Prelude.Ord b => MN3 SMPlus a b where + m >>= f = SMPlus (Set.fold (Set.union . unSM . f) Set.empty (unSM m)) + +-- We cannot forget the Ord constraint, because the typechecker +-- will complain (and tell us exactly what we have forgotten). + +-- Now we can instantiate the previously written test1s and test1d +-- functions for this Set monad: + +test2sr :: Set.Set String +test2sr = unSM $ test1s () +-- fromList ["ba"] + +test2fr :: Set.Set String +test2fr = unSM $ test1f () +-- fromList [] + +test2sr_do :: Set.Set String +test2sr_do = unSM $ test1s_do () +-- fromList ["ba"] + diff --git a/testsuite/tests/rebindable/Makefile b/testsuite/tests/rebindable/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/rebindable/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/rebindable/T303.hs b/testsuite/tests/rebindable/T303.hs new file mode 100644 index 0000000000..418a695e8d --- /dev/null +++ b/testsuite/tests/rebindable/T303.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RebindableSyntax #-}
+
+-- Trac #303
+
+module T where
+import qualified Prelude as P
+
+class IxMonad m where
+ return :: a -> m i i a
+ (>>=) :: m i j a -> (a -> m j k b) -> m i k b
+ (>>) :: m i j a -> m j k b -> m i k b
+ m >> n = m >>= \_ -> n
+
+ fail :: P.String -> m i j a
+ fail s = P.error s
+
+data T a b c = T
+instance IxMonad T where
+ return _ = T
+ m >>= f = T
+ fail _ = T
+
+testM :: T (a,b) b a
+testM = T
+
+test1 = testM >>= \x -> return x
+
+test2 = do
+ x <- testM
+ return x
diff --git a/testsuite/tests/rebindable/T4851.hs b/testsuite/tests/rebindable/T4851.hs new file mode 100644 index 0000000000..38ce45212f --- /dev/null +++ b/testsuite/tests/rebindable/T4851.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Arrows, RebindableSyntax #-} +module T4851 where + +import Prelude hiding ( id, (.) ) + +import Control.Category ( Category(..) ) +import Control.Arrow + +garbage x = + proc b -> + do rec (c, d) <- undefined -< (b, d) + returnA -< c diff --git a/testsuite/tests/rebindable/T5038.hs b/testsuite/tests/rebindable/T5038.hs new file mode 100644 index 0000000000..42f3df2712 --- /dev/null +++ b/testsuite/tests/rebindable/T5038.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RebindableSyntax #-} +module Main (main) where + +import Prelude + +ifThenElse True t f = f +ifThenElse False t f = t + +main = print (if True then 1 else 2 :: Int) +-- Should print 2! diff --git a/testsuite/tests/rebindable/T5038.stdout b/testsuite/tests/rebindable/T5038.stdout new file mode 100644 index 0000000000..0cfbf08886 --- /dev/null +++ b/testsuite/tests/rebindable/T5038.stdout @@ -0,0 +1 @@ +2 diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T new file mode 100644 index 0000000000..7df16d4135 --- /dev/null +++ b/testsuite/tests/rebindable/all.T @@ -0,0 +1,31 @@ +# These tests try test the rebindable-syntax feature of GHC, +# which you get when you use -XNoImplicitPrelude +# +# Written by Ashley Yakeley + +# No point in doing anything except the normal way +setTestOpts(only_ways(['normal'])); +setTestOpts(only_compiler_types(['ghc'])) + +test('rebindable1', normal, compile, ['']) +test('rebindable2', normal, compile_and_run, ['']) +test('rebindable3', normal, compile_and_run, ['']) +test('rebindable4', normal, compile_and_run, ['']) +test('rebindable5', normal, compile_and_run, ['']) + +# rebindable6 has become expected failures +# following Trac #1537 +test('rebindable6', normal, compile_fail, ['']) + +test('rebindable7', normal, compile_and_run, ['']) +test('rebindable8', normal, compile, ['']) +test('rebindable9', normal, compile, ['']) +test('rebindable10', normal, compile_and_run, ['']) + +test('T303', normal, compile, ['']) + +# Tests from Oleg +test('DoRestrictedM', normal, compile, ['']) +test('DoParamM', reqlib('mtl'), compile_fail, ['']) +test('T5038', normal, compile_and_run, ['']) +test('T4851', normal, compile, ['']) diff --git a/testsuite/tests/rebindable/rebindable1.hs b/testsuite/tests/rebindable/rebindable1.hs new file mode 100644 index 0000000000..1fb0b596fb --- /dev/null +++ b/testsuite/tests/rebindable/rebindable1.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-} + +module RebindableCase1 where + { +-- import Prelude; + import Prelude(String,undefined,Maybe(..), (==), (>=) ); + + return :: a; + return = undefined; + + infixl 1 >>=; + (>>=) :: a; + (>>=) = undefined; + + infixl 1 >>; + (>>) :: a; + (>>) = undefined; + + fail :: a; + fail = undefined; + + fromInteger :: a; + fromInteger = undefined; + + fromRational :: a; + fromRational = undefined; + + negate :: a; + negate = undefined; + + (-) :: a; + (-) = undefined; + + + test_do f g = do + { + f; + Just a <- g; + return a; + }; + + test_fromInteger = 1; + + test_fromRational = 0.5; + + test_negate a = - a; + + test_fromInteger_pattern 1 = undefined; + test_fromInteger_pattern (-1) = undefined; + test_fromInteger_pattern (a + 7) = a; + + test_fromRational_pattern 0.5 = undefined; + test_fromRational_pattern (-0.5) = undefined; + test_fromRational_pattern _ = undefined; + } diff --git a/testsuite/tests/rebindable/rebindable1.stderr b/testsuite/tests/rebindable/rebindable1.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable1.stderr diff --git a/testsuite/tests/rebindable/rebindable10.hs b/testsuite/tests/rebindable/rebindable10.hs new file mode 100644 index 0000000000..5123f0e175 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable10.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE RebindableSyntax #-} +module Main where +import Prelude + +ifThenElse :: Int -> String -> String -> String +ifThenElse a b c = case a > 0 of + True -> b + False -> c + +main :: IO () +main = do + print $ if -5 then "this fails" else "this works" + print $ if 5 then "this works" else "this fails"
\ No newline at end of file diff --git a/testsuite/tests/rebindable/rebindable10.stdout b/testsuite/tests/rebindable/rebindable10.stdout new file mode 100644 index 0000000000..925fc6dc09 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable10.stdout @@ -0,0 +1,2 @@ +"this works" +"this works" diff --git a/testsuite/tests/rebindable/rebindable2.hs b/testsuite/tests/rebindable/rebindable2.hs new file mode 100644 index 0000000000..7b626585ba --- /dev/null +++ b/testsuite/tests/rebindable/rebindable2.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-} + +module Main where + { +-- import Prelude; + import qualified Prelude; + import Prelude(String,undefined,Maybe(..),IO,putStrLn, + Integer,(++),Rational, (==), (>=) ); + + import Prelude(Monad(..)); + + debugFunc :: String -> IO a -> IO a; + debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>> + (ioa Prelude.>>= (\a -> + (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a) + )); + + newtype TM a = MkTM {unTM :: IO a}; + + instance (Monad TM) where + { + return a = MkTM (debugFunc "return" (Prelude.return a)); + + (>>=) ma amb = MkTM (debugFunc ">>=" ((Prelude.>>=) (unTM ma) (\a -> unTM (amb a)))); + + (>>) ma mb = MkTM (debugFunc ">>" ((Prelude.>>) (unTM ma) (unTM mb))); + + fail s = MkTM (debugFunc "fail" (Prelude.return undefined)); + }; + + preturn a = MkTM (Prelude.return a); + + fromInteger :: Integer -> Integer; + fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times + + fromRational :: Rational -> Rational; + fromRational a = a Prelude.+ a Prelude.+ a; -- three times + + negate :: a -> a; + negate a = a; -- don't actually negate + + (-) :: a -> a -> a; + (-) x y = y; -- changed function + + + test_do f g = do + { + f; -- >> + Just a <- g; -- >>= (and fail if g returns Nothing) + return a; -- return + }; + + test_fromInteger = 27; + + test_fromRational = 31.5; + + test_negate a = - a; + + test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a); + test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a); + test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a; + + test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a); + test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a); + test_fromRational_pattern a = "_=" ++ (Prelude.show a); + + tmPutStrLn s = MkTM (putStrLn s); + + doTest :: String -> TM a -> IO (); + doTest s ioa = + (putStrLn ("start test " ++ s)) + Prelude.>> + (unTM ioa) + Prelude.>> + (putStrLn ("end test " ++ s)); + + main :: IO (); + main = + (doTest "test_do failure" + (test_do (preturn ()) (preturn Nothing)) + ) + Prelude.>> + (doTest "test_do success" + (test_do (preturn ()) (preturn (Just ()))) + ) + Prelude.>> + (doTest "test_fromInteger" + (tmPutStrLn (Prelude.show test_fromInteger)) -- 27 * 5 = 135 + ) + Prelude.>> + (doTest "test_fromRational" + (tmPutStrLn (Prelude.show test_fromRational)) -- 31.5 * 3 = 189%2 + ) + Prelude.>> + (doTest "test_negate" + (tmPutStrLn (Prelude.show (test_negate 3))) -- 3 * 5 = 15, non-negate + ) + Prelude.>> + (doTest "test_fromInteger_pattern 1" + (tmPutStrLn (test_fromInteger_pattern 1)) -- 1 * 5 = 5, matches "1" + ) + Prelude.>> + (doTest "test_fromInteger_pattern (-2)" + (tmPutStrLn (test_fromInteger_pattern (-2))) -- "-2" = 2 * 5 = 10 + ) + Prelude.>> + (doTest "test_fromInteger_pattern 9" + (tmPutStrLn (test_fromInteger_pattern 9)) -- "9" = 45, 45 "-" "7" = "7" = 35 + ) + Prelude.>> + (doTest "test_fromRational_pattern 0.5" + (tmPutStrLn (test_fromRational_pattern 0.5)) -- "0.5" = 3%2 + ) + Prelude.>> + (doTest "test_fromRational_pattern (-0.7)" + (tmPutStrLn (test_fromRational_pattern (-0.7))) -- "-0.7" = "0.7" = 21%10 + ) + Prelude.>> + (doTest "test_fromRational_pattern 1.7" + (tmPutStrLn (test_fromRational_pattern 1.7)) -- "1.7" = 51%10 + ); + } diff --git a/testsuite/tests/rebindable/rebindable2.stdout b/testsuite/tests/rebindable/rebindable2.stdout new file mode 100644 index 0000000000..970af0f0ab --- /dev/null +++ b/testsuite/tests/rebindable/rebindable2.stdout @@ -0,0 +1,43 @@ +start test test_do failure +++ >> +++ >>= +++ fail +-- fail +-- >>= +-- >> +end test test_do failure +start test test_do success +++ >> +++ >>= +++ return +-- return +-- >>= +-- >> +end test test_do success +start test test_fromInteger +135 +end test test_fromInteger +start test test_fromRational +189 % 2 +end test test_fromRational +start test test_negate +15 +end test test_negate +start test test_fromInteger_pattern 1 +1=5 +end test test_fromInteger_pattern 1 +start test test_fromInteger_pattern (-2) +(-2)=10 +end test test_fromInteger_pattern (-2) +start test test_fromInteger_pattern 9 +(a + 7)=35 +end test test_fromInteger_pattern 9 +start test test_fromRational_pattern 0.5 +0.5=3 % 2 +end test test_fromRational_pattern 0.5 +start test test_fromRational_pattern (-0.7) +(-0.7)=21 % 10 +end test test_fromRational_pattern (-0.7) +start test test_fromRational_pattern 1.7 +_=51 % 10 +end test test_fromRational_pattern 1.7 diff --git a/testsuite/tests/rebindable/rebindable3.hs b/testsuite/tests/rebindable/rebindable3.hs new file mode 100644 index 0000000000..682787fced --- /dev/null +++ b/testsuite/tests/rebindable/rebindable3.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-} + +module Main where + { +-- import Prelude; + import qualified Prelude; + import Prelude(String,undefined,Maybe(..),IO,putStrLn, + Integer,(++),Rational, (==), (>=) ); + + debugFunc :: String -> IO a -> IO a; + debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>> + (ioa Prelude.>>= (\a -> + (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a) + )); + + return :: a -> IO a; + return a = debugFunc "return" (Prelude.return a); + + infixl 1 >>=; + (>>=) :: IO a -> (a -> IO b) -> IO b; + (>>=) ma amb = debugFunc ">>=" ((Prelude.>>=) ma amb); + + infixl 1 >>; + (>>) :: IO a -> IO b -> IO b; + (>>) ma mb = debugFunc ">>" ((Prelude.>>) ma mb); + + fail :: String -> IO a; + fail s = debugFunc "fail" (Prelude.return undefined); +-- fail s = debugFunc "fail" (Prelude.fail s); + + fromInteger :: Integer -> Integer; + fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times + + fromRational :: Rational -> Rational; + fromRational a = a Prelude.+ a Prelude.+ a; -- three times + + negate :: a -> a; + negate a = a; -- don't actually negate + + (-) :: a -> a -> a; + (-) x y = y; -- changed function + + + test_do f g = do + { + f; -- >> + Just a <- g; -- >>= (and fail if g returns Nothing) + return a; -- return + }; + + test_fromInteger = 27; + + test_fromRational = 31.5; + + test_negate a = - a; + + test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a); + test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a); + test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a; + + test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a); + test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a); + test_fromRational_pattern a = "_=" ++ (Prelude.show a); + + + doTest :: String -> IO a -> IO (); + doTest s ioa = + (putStrLn ("start test " ++ s)) + Prelude.>> + ioa + Prelude.>> + (putStrLn ("end test " ++ s)); + + main :: IO (); + main = + (doTest "test_do failure" + (test_do (Prelude.return ()) (Prelude.return Nothing)) + ) + Prelude.>> + (doTest "test_do success" + (test_do (Prelude.return ()) (Prelude.return (Just ()))) + ) + Prelude.>> + (doTest "test_fromInteger" + (putStrLn (Prelude.show test_fromInteger)) + ) + Prelude.>> + (doTest "test_fromRational" + (putStrLn (Prelude.show test_fromRational)) + ) + Prelude.>> + (doTest "test_negate" + (putStrLn (Prelude.show (test_negate 3))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 1" + (putStrLn (test_fromInteger_pattern 1)) + ) + Prelude.>> + (doTest "test_fromInteger_pattern (-2)" + (putStrLn (test_fromInteger_pattern (-2))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 9" + (putStrLn (test_fromInteger_pattern 9)) + ) + Prelude.>> + (doTest "test_fromRational_pattern 0.5" + (putStrLn (test_fromRational_pattern 0.5)) + ) + Prelude.>> + (doTest "test_fromRational_pattern (-0.7)" + (putStrLn (test_fromRational_pattern (-0.7))) + ) + Prelude.>> + (doTest "test_fromRational_pattern 1.7" + (putStrLn (test_fromRational_pattern 1.7)) + ); + } diff --git a/testsuite/tests/rebindable/rebindable3.stdout b/testsuite/tests/rebindable/rebindable3.stdout new file mode 100644 index 0000000000..970af0f0ab --- /dev/null +++ b/testsuite/tests/rebindable/rebindable3.stdout @@ -0,0 +1,43 @@ +start test test_do failure +++ >> +++ >>= +++ fail +-- fail +-- >>= +-- >> +end test test_do failure +start test test_do success +++ >> +++ >>= +++ return +-- return +-- >>= +-- >> +end test test_do success +start test test_fromInteger +135 +end test test_fromInteger +start test test_fromRational +189 % 2 +end test test_fromRational +start test test_negate +15 +end test test_negate +start test test_fromInteger_pattern 1 +1=5 +end test test_fromInteger_pattern 1 +start test test_fromInteger_pattern (-2) +(-2)=10 +end test test_fromInteger_pattern (-2) +start test test_fromInteger_pattern 9 +(a + 7)=35 +end test test_fromInteger_pattern 9 +start test test_fromRational_pattern 0.5 +0.5=3 % 2 +end test test_fromRational_pattern 0.5 +start test test_fromRational_pattern (-0.7) +(-0.7)=21 % 10 +end test test_fromRational_pattern (-0.7) +start test test_fromRational_pattern 1.7 +_=51 % 10 +end test test_fromRational_pattern 1.7 diff --git a/testsuite/tests/rebindable/rebindable4.hs b/testsuite/tests/rebindable/rebindable4.hs new file mode 100644 index 0000000000..2c25c9a03f --- /dev/null +++ b/testsuite/tests/rebindable/rebindable4.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-} + +module Main where + { +-- import Prelude; + import qualified Prelude; + import Prelude(String,undefined,Maybe(..),IO,putStrLn, + Integer,(++),Rational, (==), (>=) ); + + debugFunc :: String -> IO a -> IO a; + debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>> + (ioa Prelude.>>= (\a -> + (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a) + )); + + infixl 1 >>=; + infixl 1 >>; + + class MyMonad m where + { + return :: a -> m a; + (>>=) :: m a -> (a -> m b) -> m b; + (>>) :: m a -> m b -> m b; + fail :: String -> m a; + }; + + instance MyMonad IO where + { + return a = debugFunc "return" (Prelude.return a); + + (>>=) ma amb = debugFunc ">>=" ((Prelude.>>=) ma amb); + + (>>) ma mb = debugFunc ">>" ((Prelude.>>) ma mb); + + fail s = debugFunc "fail" (Prelude.return undefined); + -- fail s = debugFunc "fail" (Prelude.fail s); + }; + + fromInteger :: Integer -> Integer; + fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times + + fromRational :: Rational -> Rational; + fromRational a = a Prelude.+ a Prelude.+ a; -- three times + + negate :: a -> a; + negate a = a; -- don't actually negate + + (-) :: a -> a -> a; + (-) x y = y; -- changed function + + + test_do f g = do + { + f; -- >> + Just a <- g; -- >>= (and fail if g returns Nothing) + return a; -- return + }; + + test_fromInteger = 27; + + test_fromRational = 31.5; + + test_negate a = - a; + + test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a); + test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a); + test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a; + + test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a); + test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a); + test_fromRational_pattern a = "_=" ++ (Prelude.show a); + + + doTest :: String -> IO a -> IO (); + doTest s ioa = + (putStrLn ("start test " ++ s)) + Prelude.>> + ioa + Prelude.>> + (putStrLn ("end test " ++ s)); + + main :: IO (); + main = + (doTest "test_do failure" + (test_do (Prelude.return ()) (Prelude.return Nothing)) + ) + Prelude.>> + (doTest "test_do success" + (test_do (Prelude.return ()) (Prelude.return (Just ()))) + ) + Prelude.>> + (doTest "test_fromInteger" + (putStrLn (Prelude.show test_fromInteger)) + ) + Prelude.>> + (doTest "test_fromRational" + (putStrLn (Prelude.show test_fromRational)) + ) + Prelude.>> + (doTest "test_negate" + (putStrLn (Prelude.show (test_negate 3))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 1" + (putStrLn (test_fromInteger_pattern 1)) + ) + Prelude.>> + (doTest "test_fromInteger_pattern (-2)" + (putStrLn (test_fromInteger_pattern (-2))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 9" + (putStrLn (test_fromInteger_pattern 9)) + ) + Prelude.>> + (doTest "test_fromRational_pattern 0.5" + (putStrLn (test_fromRational_pattern 0.5)) + ) + Prelude.>> + (doTest "test_fromRational_pattern (-0.7)" + (putStrLn (test_fromRational_pattern (-0.7))) + ) + Prelude.>> + (doTest "test_fromRational_pattern 1.7" + (putStrLn (test_fromRational_pattern 1.7)) + ); + } diff --git a/testsuite/tests/rebindable/rebindable4.stdout b/testsuite/tests/rebindable/rebindable4.stdout new file mode 100644 index 0000000000..970af0f0ab --- /dev/null +++ b/testsuite/tests/rebindable/rebindable4.stdout @@ -0,0 +1,43 @@ +start test test_do failure +++ >> +++ >>= +++ fail +-- fail +-- >>= +-- >> +end test test_do failure +start test test_do success +++ >> +++ >>= +++ return +-- return +-- >>= +-- >> +end test test_do success +start test test_fromInteger +135 +end test test_fromInteger +start test test_fromRational +189 % 2 +end test test_fromRational +start test test_negate +15 +end test test_negate +start test test_fromInteger_pattern 1 +1=5 +end test test_fromInteger_pattern 1 +start test test_fromInteger_pattern (-2) +(-2)=10 +end test test_fromInteger_pattern (-2) +start test test_fromInteger_pattern 9 +(a + 7)=35 +end test test_fromInteger_pattern 9 +start test test_fromRational_pattern 0.5 +0.5=3 % 2 +end test test_fromRational_pattern 0.5 +start test test_fromRational_pattern (-0.7) +(-0.7)=21 % 10 +end test test_fromRational_pattern (-0.7) +start test test_fromRational_pattern 1.7 +_=51 % 10 +end test test_fromRational_pattern 1.7 diff --git a/testsuite/tests/rebindable/rebindable5.hs b/testsuite/tests/rebindable/rebindable5.hs new file mode 100644 index 0000000000..94b3f4ef7a --- /dev/null +++ b/testsuite/tests/rebindable/rebindable5.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE RebindableSyntax, NPlusKPatterns, FlexibleInstances, + MultiParamTypeClasses, FunctionalDependencies #-} + +module Main where + { +-- import Prelude; + import qualified Prelude; + import Prelude(String,undefined,Maybe(..),IO,putStrLn, + Integer,(++),Rational, (==), (>=) ); + + debugFunc :: String -> IO a -> IO a; + debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>> + (ioa Prelude.>>= (\a -> + (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a) + )); + + infixl 1 >>=; + infixl 1 >>; + + returnIO :: a -> IO a; + returnIO = Prelude.return; + + class HasReturn m where + { + return :: a -> m a; + }; + + class HasBind m n mn | m n -> mn, m mn -> n where + { + (>>=) :: m a -> (a -> n b) -> mn b; + }; + + class HasSeq m n mn | m n -> mn, m mn -> n where + { + (>>) :: m a -> n b -> mn b; + }; + + class HasFail m where + { + fail :: String -> m a; + }; + + instance HasReturn IO where + { + return a = debugFunc "return" (returnIO a); + }; + + instance HasBind IO IO IO where + { + (>>=) ma amb = debugFunc ">>=" ((Prelude.>>=) ma amb); + }; + + instance HasSeq IO IO IO where + { + (>>) ma mb = debugFunc ">>" ((Prelude.>>) ma mb); + }; + + instance HasFail IO where + { + fail s = debugFunc "fail" (returnIO undefined); + -- fail s = debugFunc "fail" (Prelude.fail s); + }; + + class HasFromInteger a where + { + fromInteger :: a -> a; + }; + + instance HasFromInteger Integer where + { + fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times + }; + + class HasFromRational a where + { + fromRational :: a -> a; + }; + + instance HasFromRational Rational where + { + fromRational a = a Prelude.+ a Prelude.+ a; -- three times + }; + + class HasNegate a where + { + negate :: a -> a; + }; + + instance HasNegate Integer where + { + negate a = a; -- don't actually negate + }; + + instance HasNegate Rational where + { + negate a = a; -- don't actually negate + }; + + class HasMinus a where + { + (-) :: a -> a -> a; + }; + + instance HasMinus Rational where + { + (-) x y = y; -- changed function + }; + + instance HasMinus Integer where + { + (-) x y = y; -- changed function + }; + + + test_do f g = do + { + f; -- >> + Just a <- g; -- >>= (and fail if g returns Nothing) + return a; -- return + }; + + test_fromInteger :: Integer; + test_fromInteger = 27; + + test_fromRational :: Rational; + test_fromRational = 31.5; + + test_negate :: Integer -> Integer; + test_negate a = - a; + + test_fromInteger_pattern :: Integer -> String; + test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a); + test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a); + test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a; + + test_fromRational_pattern :: Rational -> String; + test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a); + test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a); + test_fromRational_pattern a = "_=" ++ (Prelude.show a); + + + doTest :: String -> IO a -> IO (); + doTest s ioa = + (putStrLn ("start test " ++ s)) + Prelude.>> + ioa + Prelude.>> + (putStrLn ("end test " ++ s)); + + main :: IO (); + main = + (doTest "test_do failure" + (test_do (returnIO ()) (returnIO Nothing)) + ) + Prelude.>> + (doTest "test_do success" + (test_do (returnIO ()) (returnIO (Just ()))) + ) + Prelude.>> + (doTest "test_fromInteger" + (putStrLn (Prelude.show test_fromInteger)) + ) + Prelude.>> + (doTest "test_fromRational" + (putStrLn (Prelude.show test_fromRational)) + ) + Prelude.>> + (doTest "test_negate" + (putStrLn (Prelude.show (test_negate 3))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 1" + (putStrLn (test_fromInteger_pattern 1)) + ) + Prelude.>> + (doTest "test_fromInteger_pattern (-2)" + (putStrLn (test_fromInteger_pattern (-(2::Integer)::Integer))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 9" + (putStrLn (test_fromInteger_pattern 9)) + ) + Prelude.>> + (doTest "test_fromRational_pattern 0.5" + (putStrLn (test_fromRational_pattern 0.5)) + ) + Prelude.>> + (doTest "test_fromRational_pattern (-0.7)" + (putStrLn (test_fromRational_pattern (-(0.7::Rational)::Rational))) + ) + Prelude.>> + (doTest "test_fromRational_pattern 1.7" + (putStrLn (test_fromRational_pattern 1.7)) + ) + ; + } diff --git a/testsuite/tests/rebindable/rebindable5.stderr b/testsuite/tests/rebindable/rebindable5.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable5.stderr diff --git a/testsuite/tests/rebindable/rebindable5.stdout b/testsuite/tests/rebindable/rebindable5.stdout new file mode 100644 index 0000000000..970af0f0ab --- /dev/null +++ b/testsuite/tests/rebindable/rebindable5.stdout @@ -0,0 +1,43 @@ +start test test_do failure +++ >> +++ >>= +++ fail +-- fail +-- >>= +-- >> +end test test_do failure +start test test_do success +++ >> +++ >>= +++ return +-- return +-- >>= +-- >> +end test test_do success +start test test_fromInteger +135 +end test test_fromInteger +start test test_fromRational +189 % 2 +end test test_fromRational +start test test_negate +15 +end test test_negate +start test test_fromInteger_pattern 1 +1=5 +end test test_fromInteger_pattern 1 +start test test_fromInteger_pattern (-2) +(-2)=10 +end test test_fromInteger_pattern (-2) +start test test_fromInteger_pattern 9 +(a + 7)=35 +end test test_fromInteger_pattern 9 +start test test_fromRational_pattern 0.5 +0.5=3 % 2 +end test test_fromRational_pattern 0.5 +start test test_fromRational_pattern (-0.7) +(-0.7)=21 % 10 +end test test_fromRational_pattern (-0.7) +start test test_fromRational_pattern 1.7 +_=51 % 10 +end test test_fromRational_pattern 1.7 diff --git a/testsuite/tests/rebindable/rebindable6.hs b/testsuite/tests/rebindable/rebindable6.hs new file mode 100644 index 0000000000..74d861cda8 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable6.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE RebindableSyntax, NPlusKPatterns, Rank2Types, + ScopedTypeVariables, FlexibleInstances #-} +module Main where + { +-- import Prelude; + import qualified Prelude; + import Prelude(String,undefined,Maybe(..),IO,putStrLn, + Integer,(++),Rational, (==), (>=) ); + + debugFunc :: String -> IO a -> IO a; + debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>> + (ioa Prelude.>>= (\a -> + (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a) + )); + + infixl 1 >>=; + infixl 1 >>; + + returnIO :: a -> IO a; + returnIO = Prelude.return; + + class HasReturn a where + { + return :: a; + }; + + class HasBind a where + { + (>>=) :: a; + }; + + class HasSeq a where + { + (>>) :: a; + }; + + class HasFail a where + { + fail :: a; + }; + + instance HasReturn (a -> IO a) where + { + return a = debugFunc "return" (Prelude.return a); + }; + + instance HasBind (IO a -> (a -> IO b) -> IO b) where + { + (>>=) ma amb = debugFunc ">>=" ((Prelude.>>=) ma amb); + }; + + instance HasSeq (IO a -> IO b -> IO b) where + { + (>>) ma mb = debugFunc ">>" ((Prelude.>>) ma mb); + }; + + instance HasFail (String -> IO a) where + { + fail s = debugFunc "fail" (Prelude.return undefined); + -- fail s = debugFunc "fail" (Prelude.fail s); + }; + + class HasFromInteger a where + { + fromInteger :: a; + }; + + instance HasFromInteger (Integer -> Integer) where + { + fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times + }; + + class HasFromRational a where + { + fromRational :: a; + }; + + instance HasFromRational (Rational -> Rational) where + { + fromRational a = a Prelude.+ a Prelude.+ a; -- three times + }; + + class HasNegate a where + { + negate :: a; + }; + + instance HasNegate (a -> a) where + { + negate a = a; -- don't actually negate + }; + + class HasMinus a where + { + (-) :: a; + }; + + instance HasMinus (a -> a -> a) where + { + (-) x y = y; -- changed function + }; + + test_do :: forall a b. IO a -> IO (Maybe b) -> IO b; + test_do f g = do + { + f; -- >> + Just (b::b) <- g; -- >>= (and fail if g returns Nothing) + return b; -- return + }; + + test_fromInteger :: Integer; + test_fromInteger = 27; + + test_fromRational :: Rational; + test_fromRational = 31.5; + + test_negate :: Integer -> Integer; + test_negate a = - a; + + test_fromInteger_pattern :: Integer -> String; + test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a); + test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a); + test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a; + + test_fromRational_pattern :: Rational -> String; + test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a); + test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a); + test_fromRational_pattern a = "_=" ++ (Prelude.show a); + + + doTest :: String -> IO a -> IO (); + doTest s ioa = + (putStrLn ("start test " ++ s)) + Prelude.>> + ioa + Prelude.>> + (putStrLn ("end test " ++ s)); + + main :: IO (); + main = + (doTest "test_do failure" + (test_do (Prelude.return ()) (Prelude.return Nothing)) + ) + Prelude.>> + (doTest "test_do success" + (test_do (Prelude.return ()) (Prelude.return (Just ()))) + ) + Prelude.>> + (doTest "test_fromInteger" + (putStrLn (Prelude.show test_fromInteger)) + ) + Prelude.>> + (doTest "test_fromRational" + (putStrLn (Prelude.show test_fromRational)) + ) + Prelude.>> + (doTest "test_negate" + (putStrLn (Prelude.show (test_negate 3))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 1" + (putStrLn (test_fromInteger_pattern 1)) + ) + Prelude.>> + (doTest "test_fromInteger_pattern (-2)" + (putStrLn (test_fromInteger_pattern (-(2::Integer)::Integer))) + ) + Prelude.>> + (doTest "test_fromInteger_pattern 9" + (putStrLn (test_fromInteger_pattern 9)) + ) + Prelude.>> + (doTest "test_fromRational_pattern 0.5" + (putStrLn (test_fromRational_pattern 0.5)) + ) + Prelude.>> + (doTest "test_fromRational_pattern (-0.7)" + (putStrLn (test_fromRational_pattern (-(0.7::Rational)::Rational))) + ) + Prelude.>> + (doTest "test_fromRational_pattern 1.7" + (putStrLn (test_fromRational_pattern 1.7)) + ); + } diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr new file mode 100644 index 0000000000..d451400514 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable6.stderr @@ -0,0 +1,64 @@ + +rebindable6.hs:106:17: + No instance for (HasSeq (IO a -> t0 -> IO b)) + arising from a do statement + Possible fix: + add an instance declaration for (HasSeq (IO a -> t0 -> IO b)) + In a stmt of a 'do' block: f + In the expression: + do { f; + Just (b :: b) <- g; + return b } + In an equation for `test_do': + test_do f g + = do { f; + Just (b :: b) <- g; + return b } + +rebindable6.hs:107:17: + No instance for (HasFail ([Prelude.Char] -> t1)) + arising from a do statement + Possible fix: + add an instance declaration for (HasFail ([Prelude.Char] -> t1)) + In a stmt of a 'do' block: Just (b :: b) <- g + In the expression: + do { f; + Just (b :: b) <- g; + return b } + In an equation for `test_do': + test_do f g + = do { f; + Just (b :: b) <- g; + return b } + +rebindable6.hs:107:17: + No instance for (HasBind (IO (Maybe b) -> (Maybe b -> t1) -> t0)) + arising from a do statement + Possible fix: + add an instance declaration for + (HasBind (IO (Maybe b) -> (Maybe b -> t1) -> t0)) + In a stmt of a 'do' block: Just (b :: b) <- g + In the expression: + do { f; + Just (b :: b) <- g; + return b } + In an equation for `test_do': + test_do f g + = do { f; + Just (b :: b) <- g; + return b } + +rebindable6.hs:108:17: + No instance for (HasReturn (b -> t1)) + arising from a use of `return' + Possible fix: add an instance declaration for (HasReturn (b -> t1)) + In a stmt of a 'do' block: return b + In the expression: + do { f; + Just (b :: b) <- g; + return b } + In an equation for `test_do': + test_do f g + = do { f; + Just (b :: b) <- g; + return b } diff --git a/testsuite/tests/rebindable/rebindable6.stdout b/testsuite/tests/rebindable/rebindable6.stdout new file mode 100644 index 0000000000..ff6a69e060 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable6.stdout @@ -0,0 +1,43 @@ +start test test_do failure +++ >> +++ >>= +++ fail +-- fail +-- >>= +-- >> +end test test_do failure +start test test_do success +++ >> +++ >>= +++ return +-- return +-- >>= +-- >> +end test test_do success +start test test_fromInteger +135 +end test test_fromInteger +start test test_fromRational +189%2 +end test test_fromRational +start test test_negate +15 +end test test_negate +start test test_fromInteger_pattern 1 +1=5 +end test test_fromInteger_pattern 1 +start test test_fromInteger_pattern (-2) +(-2)=10 +end test test_fromInteger_pattern (-2) +start test test_fromInteger_pattern 9 +(a + 7)=35 +end test test_fromInteger_pattern 9 +start test test_fromRational_pattern 0.5 +0.5=3%2 +end test test_fromRational_pattern 0.5 +start test test_fromRational_pattern (-0.7) +(-0.7)=21%10 +end test test_fromRational_pattern (-0.7) +start test test_fromRational_pattern 1.7 +_=51%10 +end test test_fromRational_pattern 1.7 diff --git a/testsuite/tests/rebindable/rebindable7.hs b/testsuite/tests/rebindable/rebindable7.hs new file mode 100644 index 0000000000..8e0000e0e5 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable7.hs @@ -0,0 +1,38 @@ +{-# OPTIONS -XRebindableSyntax #-}
+
+-- This one tests rebindable syntax for do-notation
+
+module Main where
+
+import qualified Prelude
+import GHC.Num
+import GHC.Base hiding( Monad(..) )
+
+class Foo a where
+ op :: a -> a
+
+data T a = MkT a
+
+instance Foo Int where
+ op x = x+1
+
+(>>=) :: Foo a => T a -> (a -> T b) -> T b
+(>>=) (MkT x) f = f (op x)
+
+(>>) :: Foo a => T a -> T b -> T b
+(>>) x y = x >>= (\_ -> y)
+
+return :: Num a => a -> T a
+return x = MkT (x+1)
+
+fail :: String -> T a
+fail s = error "urk"
+
+t1 :: T Int
+t1 = MkT 4
+
+myt = do { x <- t1
+ ; return x }
+
+main = case myt of
+ MkT i -> Prelude.print i
diff --git a/testsuite/tests/rebindable/rebindable7.stdout b/testsuite/tests/rebindable/rebindable7.stdout new file mode 100644 index 0000000000..f1c101bdd7 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable7.stdout @@ -0,0 +1 @@ +6
diff --git a/testsuite/tests/rebindable/rebindable8.hs b/testsuite/tests/rebindable/rebindable8.hs new file mode 100644 index 0000000000..2c1f484f47 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable8.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RebindableSyntax, MultiParamTypeClasses #-} + +-- Trac #1537 + +module Foo where +import Prelude hiding (Monad(..)) + +class Bind m1 m2 m3 where + (>>=) :: m1 a -> (a -> m2 b) -> m3 b + +class Return m where + return :: a -> m a + fail :: String -> m a + +instance Bind Maybe [] [] where + Just x >>= f = f x + Nothing >>= f = [] + +instance Return [] where + return x = [x] + fail _ = [] + +should_compile :: [Int] +should_compile = do + a <- Just 1 + [a] diff --git a/testsuite/tests/rebindable/rebindable9.hs b/testsuite/tests/rebindable/rebindable9.hs new file mode 100644 index 0000000000..081e22c46f --- /dev/null +++ b/testsuite/tests/rebindable/rebindable9.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RebindableSyntax, FlexibleInstances, + MultiParamTypeClasses, FunctionalDependencies #-} + +-- Trac #1537 + +module Foo where +import qualified Prelude +import Prelude hiding (Monad(..)) + +newtype Identity a = Identity { runIdentity :: a } + +instance Prelude.Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +class Bind m1 m2 m3 | m1 m2 -> m3 where + (>>=) :: m1 a -> (a -> m2 b) -> m3 b + +class Return m where + returnM :: a -> m a + fail :: String -> m a + +instance Bind Maybe [] [] where + Just x >>= f = f x + Nothing >>= f = [] + +instance Functor a => Bind Identity a a where m >>= f = f (runIdentity m) +instance Functor a => Bind a Identity a where m >>= f = fmap (runIdentity . f) m + +instance Prelude.Monad m => Bind m m m where (>>=) = (Prelude.>>=) + +instance Return [] where + returnM x = [x] + fail _ = [] + +return :: a -> Identity a +return = Prelude.return + +should_compile :: [Int] +should_compile = do + a <- Just 1 + b <- [a*1,a*2] + return (b+1)
\ No newline at end of file |