summaryrefslogtreecommitdiff
path: root/testsuite/tests/rebindable
diff options
context:
space:
mode:
authorDavid Terei <davidterei@gmail.com>2011-07-20 11:09:03 -0700
committerDavid Terei <davidterei@gmail.com>2011-07-20 11:26:35 -0700
commit16514f272fb42af6e9c7674a9bd6c9dce369231f (patch)
treee4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/rebindable
parentebd422aed41048476aa61dd4c520d43becd78682 (diff)
downloadhaskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/rebindable')
-rw-r--r--testsuite/tests/rebindable/DoParamM.hs303
-rw-r--r--testsuite/tests/rebindable/DoParamM.stderr25
-rw-r--r--testsuite/tests/rebindable/DoRestrictedM.hs99
-rw-r--r--testsuite/tests/rebindable/Makefile3
-rw-r--r--testsuite/tests/rebindable/T303.hs30
-rw-r--r--testsuite/tests/rebindable/T4851.hs12
-rw-r--r--testsuite/tests/rebindable/T5038.hs10
-rw-r--r--testsuite/tests/rebindable/T5038.stdout1
-rw-r--r--testsuite/tests/rebindable/all.T31
-rw-r--r--testsuite/tests/rebindable/rebindable1.hs55
-rw-r--r--testsuite/tests/rebindable/rebindable1.stderr0
-rw-r--r--testsuite/tests/rebindable/rebindable10.hs13
-rw-r--r--testsuite/tests/rebindable/rebindable10.stdout2
-rw-r--r--testsuite/tests/rebindable/rebindable2.hs122
-rw-r--r--testsuite/tests/rebindable/rebindable2.stdout43
-rw-r--r--testsuite/tests/rebindable/rebindable3.hs119
-rw-r--r--testsuite/tests/rebindable/rebindable3.stdout43
-rw-r--r--testsuite/tests/rebindable/rebindable4.hs127
-rw-r--r--testsuite/tests/rebindable/rebindable4.stdout43
-rw-r--r--testsuite/tests/rebindable/rebindable5.hs196
-rw-r--r--testsuite/tests/rebindable/rebindable5.stderr0
-rw-r--r--testsuite/tests/rebindable/rebindable5.stdout43
-rw-r--r--testsuite/tests/rebindable/rebindable6.hs184
-rw-r--r--testsuite/tests/rebindable/rebindable6.stderr64
-rw-r--r--testsuite/tests/rebindable/rebindable6.stdout43
-rw-r--r--testsuite/tests/rebindable/rebindable7.hs38
-rw-r--r--testsuite/tests/rebindable/rebindable7.stdout1
-rw-r--r--testsuite/tests/rebindable/rebindable8.hs26
-rw-r--r--testsuite/tests/rebindable/rebindable9.hs43
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