summaryrefslogtreecommitdiff
path: root/testsuite/tests/rebindable/rebindable2.hs
blob: 7b626585ba75f5a0ee535954a54f74984edf2d1d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
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
		);
	}