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
123
124
125
126
127
128
129
130
131
132
|
{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-}
module Main where
{
-- import Prelude;
import qualified Prelude;
import Prelude(String,undefined,Maybe(..),IO,putStrLn,
Integer,(++),Rational, (==), (>=) );
import Prelude(Monad(..),Applicative(..),Functor(..));
import Control.Monad(ap, liftM);
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 (Functor TM) where
{
fmap = liftM;
};
instance (Applicative TM) where
{
pure = return;
(<*>) = ap;
};
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
);
}
|
