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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
module Assertion(
Assertion,assertTrue,assertEqual,
assertValues,assertSolutions,assertIO,assertEqualIO,
checkAssertion,
seqStrActions,writeAssertResult,
ProtocolMsg(..),
showTestMod,showTestCase,showTestEnd,showTestCompileError)
where
import AllSolutions
import List((\\))
import Socket
import IO(hPutStrLn,hClose)
import Distribution(curryCompiler)
infixl 1 `seqStrActions`
data Assertion a = AssertTrue String Bool
| AssertEqual String a a
| AssertValues String a [a]
| AssertSolutions String (a->Bool) [a]
| AssertIO String (IO a) a
| AssertEqualIO String (IO a) (IO a)
assertTrue :: String -> Bool -> Assertion ()
assertTrue s b = AssertTrue s b
assertEqual :: String -> a -> a -> Assertion a
assertEqual s x y = AssertEqual s x y
assertValues :: String -> a -> [a] -> Assertion a
assertValues s x y = AssertValues s x y
assertSolutions :: String -> (a->Bool) -> [a] -> Assertion a
assertSolutions s x y = AssertSolutions s x y
assertIO :: String -> IO a -> a -> Assertion a
assertIO s x y = AssertIO s x y
assertEqualIO :: String -> IO a -> IO a -> Assertion a
assertEqualIO s x y = AssertEqualIO s x y
seqStrActions :: IO (String,Bool) -> IO (String,Bool) -> IO (String,Bool)
seqStrActions a1 a2 =
do (s1,b1) <- a1
(s2,b2) <- a2
return (s1++s2,b1&&b2)
checkAssertion :: String -> ((String,Bool) -> IO (String,Bool)) -> Assertion _
-> IO (String,Bool)
checkAssertion asrtop prot assrt = catchNDIO asrtop prot (execAsrt assrt)
where
execAsrt (AssertTrue name cond) =
catch (checkAssertTrue name cond) (returnError name) >>= prot
execAsrt (AssertEqual name call result) =
catch (checkAssertEqual name call result) (returnError name) >>= prot
execAsrt (AssertValues name expr results) =
catch (checkAssertValues name expr results) (returnError name) >>= prot
execAsrt (AssertSolutions name constr results) =
catch (checkAssertSolutions name constr results) (returnError name) >>= prot
execAsrt (AssertIO name action result) =
catch (checkAssertIO name action result) (returnError name) >>= prot
execAsrt (AssertEqualIO name action1 action2) =
catch (checkAssertEqualIO name action1 action2) (returnError name) >>= prot
returnError name err =
return ("FAILURE of "++name++": "++showError err++"\n",False)
catchNDIO :: String -> ((String,Bool) -> IO (String,Bool))
-> IO (String,Bool) -> IO (String,Bool)
catchNDIO fname prot a =
if curryCompiler == "kics2"
then
getAllValues a >>= checkIOActions
else catch a (\e -> prot ("ERROR in "++fname++": "++showError e++"\n",False))
where
checkIOActions results
| null results
= prot ("ERROR in "++fname++": computation failed\n",False)
| not (null (tail results))
= prot ("ERROR in "++fname++
": computation is non-deterministic\n",False)
| otherwise = head results
checkAssertTrue :: String -> Bool -> IO (String,Bool)
checkAssertTrue name cond = catchNDIO name return $
if cond
then return ("OK: "++name++"\n",True)
else return ("FAILURE of "++name++": assertion not satisfied:\n",False)
checkAssertEqual :: String -> a -> a -> IO (String,Bool)
checkAssertEqual name call result = catchNDIO name return $
if call==result
then return ("OK: "++name++"\n",True)
else return ("FAILURE of "++name++": equality assertion not satisfied:\n"++
"Computed answer: "++show call++"\n"++
"Expected answer: "++show result++"\n",False)
checkAssertValues :: String -> a -> [a] -> IO (String,Bool)
checkAssertValues name call results = do
rs <- getAllValues call
if null (rs \\ results) && null (results \\ rs)
then return ("OK: "++name++"\n",True)
else return ("FAILURE of "++name++": values assertion not satisfied:\n"++
"Computed values: "++show rs++"\n"++
"Expected values: "++show results++"\n",False)
checkAssertSolutions :: String -> (a->Bool) -> [a] -> IO (String,Bool)
checkAssertSolutions name constr results = do
rs <- getAllSolutions constr
if null (rs \\ results) && null (results \\ rs)
then return ("OK: "++name++"\n",True)
else return ("FAILURE of "++name++": solutions assertion not satisfied:\n"++
"Computed values: "++show rs++"\n"++
"Expected values: "++show results++"\n",False)
checkAssertIO :: String -> IO a -> a -> IO (String,Bool)
checkAssertIO name action result = do
r <- action
if r==result
then return ("OK: "++name++"\n",True)
else return ("FAILURE of "++name++": IO assertion not satisfied:\n"++
"Computed answer: "++show r++"\n"++
"Expected answer: "++show result++"\n\n",False)
checkAssertEqualIO :: String -> IO a -> IO a -> IO (String,Bool)
checkAssertEqualIO name action1 action2 = do
r1 <- action1
r2 <- action2
if r1==r2
then return ("OK: "++name++"\n",True)
else return ("FAILURE of "++name++": IO equality assertion not satisfied:\n"++
"Computed answer 1: "++show r1++"\n"++
"Computed answer 2: "++show r2++"\n\n",False)
writeAssertResult :: (String,Bool) -> IO Int
writeAssertResult (result,flag) =
if flag
then putStrLn (result++"All tests successfully passed.") >> return 0
else putStrLn (result++"FAILURE occurred in some assertions!\n") >> return 1
data ProtocolMsg = TestModule String | TestCase String Bool | TestFinished
| TestCompileError
showTestMod :: Int -> String -> IO ()
showTestMod portnum modname = sendToLocalSocket portnum (TestModule modname)
showTestCase :: Int -> (String,Bool) -> IO (String,Bool)
showTestCase portnum (s,b) = do
sendToLocalSocket portnum (TestCase s b)
return (s,b)
showTestEnd :: Int -> IO ()
showTestEnd portnum = sendToLocalSocket portnum TestFinished
showTestCompileError :: Int -> IO ()
showTestCompileError portnum = sendToLocalSocket portnum TestCompileError
sendToLocalSocket :: Int -> ProtocolMsg -> IO ()
sendToLocalSocket portnum msg = do
h <- connectToSocket "localhost" portnum
hPutStrLn h (show msg)
hClose h
|