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
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
|
module Main ( main ) where
import Prelude hiding (catch)
import Control.Exception.Extensible ( ArithException(..), finally )
import Control.Monad.CatchIO ( catch, throw )
import Control.Monad ( liftM, when )
import Control.Monad.Error ( Error, MonadError(catchError) )
import System.IO
import System.FilePath
import System.Directory
import System.Exit
import Test.HUnit ( (@?=), (@?) )
import qualified Test.HUnit as HUnit
import Language.Haskell.Interpreter
test_reload_modified :: TestCase
test_reload_modified = TestCase "reload_modified" [mod_file] $ do
liftIO $ writeFile mod_file mod_v1
f_v1 <- get_f
--
liftIO $ writeFile mod_file mod_v2
f_v2 <- get_f
--
liftIO $ (f_v1 5, f_v2 5) @?= (5, 6)
--
where mod_name = "TEST_ReloadModified"
mod_file = mod_name ++ ".hs"
--
mod_v1 = unlines ["module " ++ mod_name,
"where",
"f :: Int -> Int",
"f = id"]
mod_v2 = unlines ["module " ++ mod_name,
"where",
"f :: Int -> Int",
"f = (1 +)"]
--
get_f = do loadModules [mod_file]
setTopLevelModules [mod_name]
interpret "f" (as :: Int -> Int)
test_lang_exts :: TestCase
test_lang_exts = TestCase "lang_exts" [mod_file] $ do
liftIO $ writeFile mod_file "data T where T :: T"
fails do_load @@? "first time, it shouldn't load"
--
set [languageExtensions := glasgowExtensions]
succeeds do_load @@? "now, it should load"
--
set [languageExtensions := []]
fails do_load @@? "it shouldn't load, again"
--
where mod_name = "TEST_LangExts"
mod_file = mod_name ++ ".hs"
--
do_load = loadModules [mod_name]
test_work_in_main :: TestCase
test_work_in_main = TestCase "work_in_main" [mod_file] $ do
liftIO $ writeFile mod_file "f = id"
loadModules [mod_file]
setTopLevelModules ["Main"]
setImportsQ [("Prelude",Nothing),
("Data.Maybe", Just "Mb")]
--
typeOf "f $ 1+1" @@?= "(Num a) => a"
eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]"
interpret "f $ 1 == 2" infer @@?= False
--
where mod_file = "TEST_WorkInMain.hs"
test_priv_syms_in_scope :: TestCase
test_priv_syms_in_scope = TestCase "private_syms_in_scope" [mod_file] $ do
-- must set to True, otherwise won't work with
-- ghc 6.8
set [installedModulesInScope := True]
liftIO $ writeFile mod_file mod_text
loadModules [mod_file]
setTopLevelModules ["T"]
typeChecks "g" @@? "g is hidden"
where mod_text = unlines ["module T(f) where", "f = g", "g = id"]
mod_file = "TEST_PrivateSymbolsInScope.hs"
test_comments_in_expr :: TestCase
test_comments_in_expr = TestCase "comments_in_expr" [] $ do
setImports ["Prelude"]
let expr = "length $ concat [[1,2],[3]] -- bla"
typeChecks expr @@? "comment on expression"
eval expr
interpret expr (as :: Int)
return ()
test_qual_import :: TestCase
test_qual_import = TestCase "qual_import" [] $ do
setImportsQ [("Prelude", Nothing),
("Data.Map", Just "M")]
typeChecks "null []" @@? "Unqual null"
typeChecks "M.null M.empty" @@? "Qual null"
return ()
test_basic_eval :: TestCase
test_basic_eval = TestCase "basic_eval" [] $ do
eval "()" @@?= "()"
test_show_in_scope :: TestCase
test_show_in_scope = TestCase "show_in_scope" [] $ do
setImports ["Prelude"]
eval "show ([] :: String)" @@?= show (show "")
test_installed_not_in_scope :: TestCase
test_installed_not_in_scope = TestCase "installed_not_in_scope" [] $ do
b <- get installedModulesInScope
succeeds action @@?= b
set [installedModulesInScope := False]
fails action @@? "now must be out of scope"
set [installedModulesInScope := True]
succeeds action @@? "must be in scope again"
where action = typeOf "Data.Map.singleton"
test_search_path :: TestCase
test_search_path =
TestCase "search_path" files $ do
liftIO setup
fails (loadModules [mod_1]) @@? "mod_1 should not be in path (1)"
fails (loadModules [mod_2]) @@? "mod_2 should not be in path (1)"
--
set [searchPath := [dir_1]]
succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (2)"
fails (loadModules [mod_2]) @@? "mod_2 should not be in path (2)"
--
set [searchPath := [dir_2]]
fails (loadModules [mod_1]) @@? "mod_1 should not be in path (3)"
succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (3)"
--
set [searchPath := [dir_1,dir_2]]
succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (4)"
succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (4)"
where dir_1 = "search_path_test_dir_1"
mod_1 = "M1"
file_1 = dir_1 </> mod_1 <.> "hs"
dir_2 = "search_path_test_dir_2"
mod_2 = "M2"
file_2 = dir_2 </> mod_2 <.> "hs"
files = [file_1, file_2, dir_1, dir_2]
setup = do createDirectory dir_1
createDirectory dir_2
writeFile file_1 $
unlines ["module " ++ mod_1,
"where",
"x :: Int",
"x = 42"]
writeFile file_2 $
unlines ["module " ++ mod_2,
"where",
"y :: Bool",
"y = False"]
test_search_path_dot :: TestCase
test_search_path_dot =
TestCase "search_path_dot" [mod_file, dir] $ do
liftIO setup
succeeds (loadModules [mod1]) @@? "mod1 must be initially in path"
set [searchPath := [dir]]
succeeds (loadModules [mod1]) @@? "mod1 must be still in path"
--
where dir = "search_path_dot_dir"
mod1 = "M1"
mod_file = mod1 <.> "hs"
setup = do createDirectory dir
writeFile mod_file $
unlines ["x :: Int", "x = 42"]
test_catch :: TestCase
test_catch = TestCase "catch" [] $ do
setImports ["Prelude"]
succeeds (action `catch` handler) @@? "catch failed"
where handler DivideByZero = return "catched"
handler e = throw e
action = do s <- eval "1 `div` 0 :: Int"
return $! s
tests :: [TestCase]
tests = [test_reload_modified,
test_lang_exts,
test_work_in_main,
test_comments_in_expr,
test_qual_import,
test_basic_eval,
test_show_in_scope,
test_installed_not_in_scope,
test_priv_syms_in_scope,
test_search_path,
test_search_path_dot,
test_catch]
main :: IO ()
main = do -- run the tests...
c <- runTests False tests
-- then run again, but with sandboxing on...
c' <- runTests True tests
--
let failures = HUnit.errors c + HUnit.failures c +
HUnit.errors c' + HUnit.failures c'
exit_code
| failures > 0 = ExitFailure failures
| otherwise = ExitSuccess
exitWith exit_code
-- `catch` (\_ -> exitWith (ExitFailure $ -1))
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError = hPutStrLn stderr . show
setSandbox :: Interpreter ()
setSandbox = set [installedModulesInScope := False]
(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >=> g = \a -> f a >>= g
(@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m ()
p @@? msg = do b <- p; liftIO (b @? msg)
(@@?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()
m_a @@?= b = do a <- m_a; liftIO (a @?= b)
fails :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool
fails action = (action >> return False) `catchError` (\_ -> return True)
succeeds :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool
succeeds = liftM not . fails
data TestCase = TestCase String [FilePath] (Interpreter ())
runTests :: Bool -> [TestCase] -> IO HUnit.Counts
runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build
where build (TestCase title tmps test) = HUnit.TestLabel title $
HUnit.TestCase test_case
where test_case = go `finally` clean_up
clean_up = mapM_ removeIfExists tmps
go = do r <- runInterpreter
(when sandboxed setSandbox >> test)
either (printInterpreterError >=> (fail . show))
return r
removeIfExists f = do existsF <- doesFileExist f
if existsF
then removeFile f
else
do existsD <- doesDirectoryExist f
when existsD $
removeDirectory f
|
