CmdSemantics.hs 21.5 KB
Newer Older
1

2
module CmdSemantics ( parseOneTFile, processParsedTFile )
3
4
5
where

import CmdSyntax
6
import CmdParser	( parseScript )
7
import TopSort		( topSort )
8
import Maybe		( isJust, fromJust )
9
import Monad		( when )
10
import Directory	( doesFileExist, removeFile )
11
import System		( ExitCode(..) )
12
import List		( nub, (\\) )
13
14
import Char		( ord )
import IO
15

16
17
18
#ifdef __NHC__
import NonStdTrace(trace)
#else
19
import IOExts(trace)
20
#endif
21
22
23
24
25
26
27
28
29
30
31
32
33
34
---------------------------------------------------------------------
-- Hook into Meurig Sage's regexp library

import Regexp		( MatcherFlag(..), searchS, legalRegexp, matchedAny )

myMatchRegexp :: String -> String -> Maybe Bool
myMatchRegexp rx str
   -- | trace (show (rx, str)) True
   = let result = searchS rx [Multi_Line] str
     in  if   not (legalRegexp result)
         then Nothing
         else Just (matchedAny result)

---------------------------------------------------------------------
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
-- A monad to carry around the EvalEnv.

type IOE a  = EvalEnv -> IO (EvalEnv, a)

thenE :: IOE a -> (a -> IOE b) -> IOE b
thenE x y p
   = do (p2, xv) <- x p
        y xv p2

thenE_ :: IOE a -> IOE b -> IOE b
thenE_ x y p
   = do (p2, xv) <- x p
        y p2

returnE :: a -> IOE a
returnE x p = return (p, x)

getEvalEnv :: IOE EvalEnv
getEvalEnv p = return (p, p)

setEvalEnv :: EvalEnv -> IOE ()
56
57
58
59
60
61
62
63
64
setEvalEnv pnew p = return (pnew, ())


getLocalEnv :: IOE [(Var,String)]
getLocalEnv p = return (p, locals p)

setLocalEnv :: [(Var,String)] -> IOE ()
setLocalEnv l_env p
   = return (p{locals=l_env}, ())
65
66
67
68


---------------------------------------------------------------------
-- Enhanced version of IOE, which propagates failure values immediately.
69

70
71
data EvalResult a
   = FrameFail  String			-- failure; act like "throw"
72
   | Results    (Result, Result)	-- final result (exp,act); ditto
73
74
75
   | Value      a			-- value; keep going


76
type IOEV a = IOE (EvalResult a)
77

78
79
returnEV :: a -> IOE (EvalResult a)
returnEV x p = return (p, Value x)
80

81
failEV :: String -> IOE (EvalResult a)
82
failEV str p = return (p, FrameFail ("framework failure: " ++ str))
83

84
85
resultsEV :: (Result, Result) -> IOE (EvalResult a)
resultsEV (r1,r2) p = return (p, Results (r1,r2))
86

87
88
89
failagainEV :: String -> IOE (EvalResult a)
failagainEV str p = return (p, FrameFail str)

90
91
92
93
94
thenEV :: IOEV a -> (a -> IOEV b) -> IOEV b
thenEV x y
   = x 						`thenE` \ res_x ->
     case res_x of
        Value x_ok  -> y x_ok
95
        FrameFail s -> failagainEV s
96
        Results rs  -> resultsEV rs
97

98
99
100
101
102
thenEV_ :: IOEV a -> IOEV b -> IOEV b
thenEV_ x y
   = x 						`thenE` \ res_x ->
     case res_x of
        Value x_ok  -> y
103
        FrameFail s -> failagainEV s
104
        Results rs  -> resultsEV rs
105

106
107
108
109
110
111
112
113
114
115
116
117
mapEV :: (a -> IOEV b) -> [a] -> IOEV [b]
mapEV f []     = returnEV []
mapEV f (x:xs) = f x       			`thenEV` \ x_done ->
                mapEV f xs 			`thenEV` \ xs_done ->
                returnEV (x_done:xs_done)

whenEV :: Bool -> IOEV () -> IOEV ()
whenEV b act
   = if b then act else returnEV ()

ioToEV :: IO a -> IOEV a
ioToEV io p
118
   = do r <- io
119
        return (p, Value r)
120
121
122
123
124
125
126
127
128

bind x f = f x


---------------------------------------------------------------------
-- environment management stuff

data EvalEnv 
   = EvalEnv {
129
130
131
132
133
134
        -- THESE NEVER CHANGE
        globals :: [(Var, String)],		-- global var binds
        mdefs   :: [(MacroName, MacroDef)],	-- macro defs
        -- WRITABLE, DISCARDED AT PROCEDURE EXIT
	locals  :: [(Var, String)],		-- local var binds
        -- THREADED
135
        results :: (Maybe Result, Maybe Result),
136
				-- expected and actual results
137
        counter :: Int		-- for generating unique file names
138
     }
139
     deriving Show
140

141
142
143
144
145
146
147
148
149
150
151
-- Record in the environment an expected or actual result.
-- Complain about duplicate assignments.
-- If the assignment now means that both an expected and actual
-- result is available, terminate computation and return these
-- results to the top level of the driver.
setResult :: Bool -> Result -> IOEV ()
setResult is_actual res
   = getEvalEnv					`thenE` \ p ->
     results p					`bind` \ (r_exp, r_act) ->
     (is_actual && isJust r_act)		`bind` \ dup_act ->
     ((not is_actual) && isJust r_exp)		`bind` \ dup_exp ->
152
153
154
155
156
     if   dup_act
     then failEV "duplicate assignment of actual outcome"
     else
     if   dup_exp
     then failEV "duplicate assignment of expected outcome"
157
158
159
160
     else
     (if is_actual then (r_exp, Just res)
                   else (Just res, r_act))	`bind` \ (new_exp, new_act) ->
     if   isJust new_exp && isJust new_act
161
     then resultsEV (fromJust new_exp, fromJust new_act)
162
163
164
165
166
167
     else 
     setEvalEnv (p{results = (new_exp, new_act)})
						`thenE_`
     returnEV ()

addLocalVarBind :: Var -> String -> IOEV ()
168
addLocalVarBind v s
169
   = getEvalEnv					`thenE` \ p ->
170
171
172
173
174
     (if   v `elem` map fst (globals p)
      	then setEvalEnv (p{globals = (v,s):(globals p)})
     	else setEvalEnv (p{locals = (v,s):(locals p)})
	) `thenE_`
    returnEV ()
175

176
177
178
179
180
181
182
getCounterE :: IOE Int
getCounterE
   = getEvalEnv					`thenE` \ p ->
     counter p					`bind` \ n ->
     setEvalEnv p{counter=n+1}			`thenE_`
     returnE (n+1)

183
184
185
186
lookupVar_maybe :: Var -> IOE (Maybe String)
lookupVar_maybe v
   = getEvalEnv					`thenE` \ p ->
     returnE (lookup v (locals p ++ globals p))
187

188
lookupVar :: Var -> IOEV String
189
lookupVar v 
190
   = lookupVar_maybe v				`thenE` \ maybe_v ->
191
192
193
     case maybe_v of
        Just xx -> returnEV xx
        Nothing -> failEV (missingVar v)
194

195
lookupMacro :: MacroName -> IOEV MacroDef
196
lookupMacro mnm
197
   = getEvalEnv					`thenE` \ p ->
198
     case lookup mnm (mdefs p) of
199
200
        Just mdef -> returnEV mdef
        Nothing   -> failEV (missingMacro mnm)
201

202
203
initialEnv global_env macro_env
   = EvalEnv{ globals=global_env, mdefs=macro_env,
204
              locals=[], results=(Nothing,Nothing), counter=0 }
205

206

207
---------------------------------------------------------------------
208
209
-- Run all the tests defined in a parsed .T file.

210
211
processParsedTFile :: Maybe [String]	-- which tests to run
                   -> FilePath
212
                   -> [(Var,String)]
213
                   -> [TopDef]
214
                   -> IO [TestResult]
215

216
217
218
219
220
221
222
223
224
processParsedTFile test_filter tfilepath initial_global_env topdefs
   = do { let raw_tests = filter isTTest topdefs
        ; when (null raw_tests) 
               (officialMsg ("=== WARNING: no tests defined in: " ++ tfilepath))
        ; let tests = getApplicableTests test_filter raw_tests
        ; if null tests
           then return []
           else

225
     do { officialMsg ("=== running tests in: " ++ tfilepath ++ " ===")
226
227
228
229
230
231
232
233
234

        ; let macs      = filter isTMacroDef topdefs
        ; let incls     = filter isTInclude  topdefs -- should be []
        ; let topbinds  = [(var,expr) | TAssign var expr <- topdefs]
        ; let macro_env = map (\(TMacroDef mnm mrhs) -> (mnm,mrhs)) macs
        ; ei_global_env <- evalTopBinds initial_global_env topbinds
        ; case ei_global_env of
             Left barfage
                -> do officialMsg barfage
235
                      return [TestFFail (TestID tfilepath tname)
236
237
238
239
240
                              | TTest tname trhs <- tests]
             Right global_env
                -> do all_done <- mapM (doOne global_env macro_env) tests
                      return all_done
     }}
241
242
     where
        doOne global_env macro_env (TTest tname stmts)
243
           = do putStr "\n"
244
                let test_id = TestID tfilepath tname
245
                officialMsg ("=== " ++ ppTestID test_id ++ " ===")
246
247
248
                r <- doOneTest (("testname", tname):global_env)
                                macro_env stmts
                case r of
249
250
                   Left barfage 
                      -> do officialMsg barfage
251
252
                            return (TestFFail test_id)
                   Right (exp,act)
253
254
255
                      -> do officialMsg ("=== outcome for " ++ tname 
                                         ++ ": exp:" ++ show exp
                                         ++ ", act:" ++ show act ++ " ===")
256
                            return (TestRanOK test_id exp act)
257
258


259
260
261
262
263
264
265
266
getApplicableTests :: Maybe [String] -> [TopDef] -> [TopDef]

getApplicableTests Nothing{-no filter-} topdefs
   = filter isTTest topdefs
getApplicableTests (Just these) topdefs
   = [ TTest tname stmts | TTest tname stmts <- topdefs, tname `elem` these]


267
268
269
270
271
272
evalTopBinds :: [(Var, String)]		-- pre-set global bindings
             -> [(Var, Expr)] 		-- top-level binds got from script
             -> IO (Either String{-complaint of some kind-}
                           [(Var, String)]{-augmented global binds-})

evalTopBinds globals binds
273
   = let f_map = [(v, nub (freeVars e)) | (v,e) <- binds]
274
     in 
275
276
277
278
279
     case topSort f_map of
        Left circular_vars
           -> return (Left ("circular dependencies for top-level vars: " 
                           ++ unwords (map ('$':) circular_vars)))
        Right eval_order
280
           -> let in_order = [ (v, fromJust (lookup v binds)) | v <- eval_order ]
281
282
              in
              loop globals in_order
283
284
285
286
287
288
289
290
291
292
     where
        loop acc [] 
           = return (Right acc)
        loop acc ((v,e):rest)
           = do let initial_env = initialEnv acc []
                (final_env, res) <- evalExpr e initial_env
                case res of
                   Value r       -> loop ((v,r):acc) rest
                   Results ress  -> panic "evalTopBinds"
                   FrameFail msg -> return (Left msg)
293
294
295
296
297

        
---------------------------------------------------------------------
-- Parsing a complete .T file and the transitive closure of its includes.

298
299
300
301
302
parseOneTFile,
 parseOneTFile_wrk :: [(Var,String)]	-- global var env
                   -> FilePath		-- the T file to parse
                   -> IO (Either String{-complaint of some sort-}
                                 (FilePath, [TopDef]))
303
304

parseOneTFile global_env tfile
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
   = do ei_parsed <- parseOneTFile_wrk global_env tfile
        case ei_parsed of
           Left barfage
              -> return (Left barfage)
           Right name_and_defs
              -> do let testnames 
                          = [testnm | TTest testnm stmts <- snd name_and_defs]
                    let dups = testnames \\ (nub testnames)
                    if null dups 
                     then return (Right name_and_defs)
                     else return (Left (tfile ++ ": duplicate tests: " 
                                        ++ unwords dups))


parseOneTFile_wrk global_env tfile
320
321
322
323
324
325
326
327
328
329
   = do { have_f <- doesFileExist tfile
        ; if not have_f
           then return (Left ("can't open script file `" ++ tfile ++ "'"))
           else 
     do { f_cts <- readFile tfile
        ; let p_result = parseScript tfile f_cts
        ; case p_result of {
              Left errmsg -> return (Left errmsg) ;
              Right topdefs -> 
     do { -- filter out the includes and recurse on them
330
331
          let here_topdefs  = filter (not.isTInclude) topdefs
        ; let here_includes = filter isTInclude topdefs
332
333
        ; incl_paths
             <- mapM ( \i -> case i of 
334
335
                                TInclude expr -> evalIncludeExpr tfile 
                                                    global_env expr
336
337
338
339
340
341
342
                     ) here_includes
        ; let bad_incl_exprs = filter isLeft incl_paths
        ; if not (null bad_incl_exprs)
            then case head bad_incl_exprs of
                    Left moanage -> return (Left moanage)
            else 
     do { let names_to_include = map unRight incl_paths
343
        ; incl_topdefss <- mapM (parseOneTFile_wrk global_env) names_to_include
344
345
346
347
348
349
350
351
352
353
354
        ; let failed_includes = filter isLeft incl_topdefss
        ; if not (null failed_includes)
            then return (head failed_includes)
            else 
     do { let more_topdefs = concatMap (snd.unRight) incl_topdefss
        ; return (Right (tfile, here_topdefs ++ more_topdefs))
     }}}}}}


-- Simplistically evaluate an expression, using just the global
-- value env.  Used for evaluating the args of include statements.
355
356
evalIncludeExpr :: FilePath		-- only used for making err msgs
                -> [(Var,String)] 
357
358
                -> Expr 
                -> IO (Either String{-errmsg-} String{-result-})
359
evalIncludeExpr tfilepath global_env expr
360
361
362
363
364
   = do let initial_env = initialEnv global_env []
        (final_env, res) <- evalExpr expr initial_env
        case res of
           Value v       -> return (Right v)
           Results ress  -> panic "evalIncludeExpr"
365
366
367
           FrameFail msg 
              -> return (Left (tfilepath ++ ": invalid include expr:\n      " 
                               ++ msg))
368
369
        
          
370

371
372
---------------------------------------------------------------------
-- Running a single test.
373
374
375
376
377
378
379

-- Run the whole show for a given test, stopping when:
-- * A framework failure occurs
-- * Both expected and actual results are determined
-- * We run out of statements and neither of the above two
--   apply.  This also counts as a framework failure.

380
381
382
doOneTest :: [(Var,String)]		-- global var env
          -> [(MacroName, MacroDef)]	-- macro env
          -> [Stmt]			-- stmts for this test
383
384
385
386
387
388
          -> IO (Either String{-framefail-} 
                        (Result, Result){-outcomes-})

doOneTest global_env code_env stmts
   = do let initial_env = initialEnv global_env code_env
        res <- doStmts stmts initial_env
389
        case snd res of
390
           FrameFail msg   -> return (Left msg)
391
392
           Value _         -> inconclusive
           Results ress    -> return (Right ress)
393
394
395
396
397
398
     where
        inconclusive 
           = return (Left ("test completed but actual/expected " ++ 
                           "results not determined"))


399
400
401
402
403
404
405
406
-- Run a bunch of statements, and return either Nothing if 
-- there was no return statement, or the value computed by said.
doStmts :: [Stmt] -> IOEV (Maybe String)
doStmts []     = returnEV Nothing
doStmts (s:ss) = doStmt s `thenEV` \ maybe_v ->
                 case maybe_v of 
                    Just xx -> returnEV (Just xx)
                    Nothing -> doStmts ss
407
408


409
doStmt :: Stmt -> IOEV (Maybe String)
410
doStmt (SAssign v expr)
411
412
413
   = evalExpr expr				`thenEV`  \ str ->
     addLocalVarBind v str			`thenEV_`
     returnEV Nothing
414
doStmt (SPrint expr)
415
416
417
   = evalExpr expr				`thenEV` \ str ->
     ioToEV (putStrLn str)			`thenEV_`
     returnEV Nothing
418
doStmt (SCond c t maybe_f)
419
   = evalExprToBool c				`thenEV` \ c_bool ->
420
421
422
     if   c_bool
     then doStmts t
     else case maybe_f of
423
             Nothing -> returnEV Nothing
424
425
426
             Just f  -> doStmts f

doStmt (SFFail expr)
427
   = evalExpr expr				`thenEV` \ res ->
428
     failagainEV ("=== user-framework-fail: " ++ res)
429
doStmt (SResult res expr)
430
431
432
433
434
435
   = evalExprToBool expr			`thenEV` \ b ->
     whenEV b (setResult True{-actual-} res)	`thenEV_`
     returnEV Nothing
doStmt (SExpect res)
   = setResult False{-expected-} res		`thenEV_`
     returnEV Nothing
436
437

doStmt (SMacro mnm args)
438
439
440
441
   = runMacro mnm args				`thenEV` \ maybe_v ->
     case maybe_v of
        Nothing -> returnEV Nothing
        Just _  -> failEV (hasValue mnm)
442
443

doStmt (SReturn expr)
444
445
   = evalExpr expr				`thenEV` \ res ->
     returnEV (Just res)
446

447
448
449
450
451
452
doStmt (SSkip expr)
   = evalExprToBool expr			`thenEV` \ skip ->
     if   skip
     then resultsEV (Skipped, Skipped)
     else returnEV Nothing

453
454
runMacro :: MacroName -> [Expr] -> IOEV (Maybe String)
runMacro mnm args
455
456
   = 
     lookupMacro mnm				`thenEV` \ mdef ->
457
     case mdef of { MacroDef formals stmts ->
458
459
     length formals				`bind` \ n_formals ->
     length args				`bind` \ n_args ->
460
     if   n_formals /= n_args
461
462
463
464
465
     then failEV (arityErr mnm n_formals n_args)
     else mapEV evalExpr args			`thenEV` \ arg_vals ->
          zip formals arg_vals			`bind`  \ new_local_env ->
          getLocalEnv				`thenE` \ our_local_env ->
          setLocalEnv new_local_env		`thenE_`
466
          getLocalEnv `thenE` \ xxx ->
467
468
469
          doStmts stmts				`thenEV` \ res ->
          setLocalEnv our_local_env		`thenE_`
          returnEV res
470
471
     }

472
473
474
475
476
477
478

---------------------------------------------------------------------
-- The expression evaluator.

fromBool b
   = if b then "True" else "False"

479
480
pipeErr p
   = "Can't run pipe `" ++ p ++ "'"
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
cantOpen f 
   = "Can't open file `" ++ f ++ "'"
regExpErr rx
   = "Invalid regexp `" ++ rx ++ "'"
missingVar v
   = "No binding for variable `$" ++ v ++ "'"
missingMacro mnm
   = "No binding for macro `" ++ mnm ++ "'"
notABool str
   = "String `" ++ str ++ "' is neither `True' nor `False'"
arityErr mnm n_formals n_actuals
   = "Macro `" ++ mnm ++ "' expects " ++ show n_formals 
     ++ " args, but was given " ++ show n_actuals
macroArg mnm arg
   = "No binding for formal param `$" ++ arg 
     ++ "' whilst expanding macro `" ++ mnm ++ "'"
497
498
isGlobalVar v
   = "Assigments to global variable `$" ++ v ++ "' are not allowed"
499
500
501
502
503
hasValue mnm
   = "Macro `" ++ mnm ++ "' used in context not expecting a value"
noValue mnm
   = "Macro `" ++ mnm ++ "' used in context expecting a value"

504

505
evalOpExpr :: Op -> String -> String -> IOEV String
506

507
508
509
evalOpExpr OpAppend s1 s2 = returnEV (s1 ++ s2)
evalOpExpr OpEq     s1 s2 = returnEV (fromBool (s1 == s2))
evalOpExpr OpNEq    s1 s2 = returnEV (fromBool (s1 /= s2))
510
511
evalOpExpr OpContains s rx 
   = case myMatchRegexp rx s of
512
513
        Nothing -> failEV (regExpErr rx)
        Just bb -> returnEV (fromBool bb)
514
515
evalOpExpr OpLacks s rx 
   = case myMatchRegexp rx s of
516
517
        Nothing -> failEV (regExpErr rx)
        Just bb -> returnEV (fromBool (not bb))
518
519


520
evalExpr :: Expr -> IOEV String
521
evalExpr (EOp op e1 e2)
522
   | op `elem` [OpEq, OpNEq, OpAppend, OpContains, OpLacks]
523
524
   = evalExpr e1 				`thenEV` \ e1s ->
     evalExpr e2 				`thenEV` \ e2s ->
525
     evalOpExpr op e1s e2s
526
evalExpr (EOp OpOr e1 e2)
527
528
529
530
   = evalExprToBool e1				`thenEV` \ b1 ->
     if b1 then returnEV (fromBool True)
           else evalExprToBool e2		`thenEV` \ b2 ->
                returnEV (fromBool b2)
531
evalExpr (EOp OpAnd e1 e2)
532
533
534
535
   = evalExprToBool e1				`thenEV` \ b1 ->
     if not b1 then returnEV (fromBool False)
               else evalExprToBool e2		`thenEV` \ b2 ->
                    returnEV (fromBool b2)
536
evalExpr (EString str)
537
   = returnEV str
538
evalExpr (EBool b)
539
   = returnEV (fromBool b)
540
evalExpr (EContents expr)
541
542
   = evalExpr expr 				`thenEV` \ filename ->
     readFileEV filename
543
evalExpr (EExists expr)
544
545
546
547
   = evalExpr expr 				`thenEV` \ filename ->
     doesFileExistEV filename			`thenEV` \ b ->
     returnEV (fromBool b)
evalExpr (EDefined v)
548
549
   | null v
   = panic ("evalExpr(EDefined): not a var " ++ v)
550
551
552
553
554
	-- This is a panic because the lexer+parser should have
	-- conspired to ensure this
   | otherwise
   = lookupVar_maybe v				`thenE` \ maybe_v ->
     returnEV (fromBool (isJust maybe_v))
555
evalExpr EOtherwise
556
   = returnEV (fromBool True)
557
evalExpr (ECond c t f)
558
   = evalExprToBool c				`thenEV` \ c_bool ->
559
     if   c_bool
560
     then evalExpr t
561
     else evalExpr f
562
evalExpr (EVar v)
563
   = lookupVar v
564
evalExpr (EFFail expr)
565
   = evalExpr expr				`thenEV` \ res ->
566
     failEV ("=== user-framework-fail: " ++ res)
567
568
569
570
evalExpr (ERun expr)
   = evalExpr expr				`thenEV` \ cmd_to_run ->
     systemEV cmd_to_run			`thenEV` \ exit_code ->
     returnEV (show exit_code)
571
572

evalExpr (EMacro mnm args)
573
574
575
576
   = runMacro mnm args				`thenEV` \ maybe_v ->
     case maybe_v of
        Nothing -> failEV (noValue mnm)
        Just xx -> returnEV xx
577

578
579
580
581
582
evalExpr (EPipe src cmd)
   = evalExpr src				`thenEV` \ src_txt ->
     evalExpr cmd				`thenEV` \ cmd_txt ->
     runPipeEV src_txt cmd_txt

583
584
-------------------------

585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
-- Go to some trouble to manufacture temp file names without recourse
-- to the FFI, since ghci can't handle FFI calls right now
myMkTempName :: String -> Int -> String
myMkTempName hashable_str ctr
   = "/tmp/testdriver_" ++ show (hash 0 hashable_str) ++ "_" ++ show ctr
     where
        hash :: Int -> String -> Int
        hash h []     = h
        hash h (c:cs) = hash (((h * 7) + ord c) `mod` 1000000000) cs

runPipeEV :: String{-src-} -> String{-cmd-} -> IOEV String
runPipeEV src cmd
   = getCounterE				`thenE` \ ctr ->
     getEvalEnv					`thenE` \ p ->
     myMkTempName (show p) ctr			`bind`  \ tmpf_root ->
     (tmpf_root ++ "_in")			`bind`  \ tmpf_in ->
     (tmpf_root ++ "_out")			`bind`  \ tmpf_out ->
     ioToEV (writeFile tmpf_in src)		`thenEV_`
     ioToEV (my_system 
               (cmd ++ " < " ++ tmpf_in 
                    ++ " > " ++ tmpf_out))	`thenEV` \ ret_code ->
     case ret_code of
        ExitFailure m -> failEV (pipeErr cmd)
        ExitSuccess 
           -> ioToEV (myReadFile tmpf_out)	`thenEV` \ result ->
              ioToEV (removeFile tmpf_in)	`thenEV_`
              ioToEV (removeFile tmpf_out)	`thenEV_`
              returnEV result

614
-- Does filename exist?
615
616
617
618
doesFileExistEV :: String -> IOEV Bool
doesFileExistEV filename
   = ioToEV (doesFileExist filename)		`thenEV` \ b ->
     returnEV b
619

620
-- Get the contents of a file.
621
622
readFileEV :: String -> IOEV String
readFileEV filename
623
   = ioToEV (doesFileExist filename) 		`thenEV` \ exists ->
624
     if   not exists 
625
     then failEV (cantOpen filename)
626
     else ioToEV (myReadFile filename) 		`thenEV` \ contents ->
627
628
     returnEV contents

629
630
631
632
633
634
635
636
637
638
639
640
641
-- Use this round-the-houses scheme to ensure we don't run out of file
-- handles.
myReadFile :: String -> IO String
myReadFile f
   = do hdl <- openFile f ReadMode
        cts <- hGetContents hdl
        case seqList cts of
           () -> do hClose hdl
                    return cts

-- sigh ...
seqList []     = ()
seqList (x:xs) = seqList xs
642

643
-- Run a command.
644
645
646
systemEV :: String -> IOEV Int
systemEV str
   = ioToEV (my_system str) 			`thenEV` \ ret_code ->
647
     case ret_code of
648
649
        ExitSuccess   -> returnEV 0
        ExitFailure m -> returnEV m
650
651
652

---------------------------

653
654
655
evalExprToBool :: Expr -> IOEV Bool
evalExprToBool e
   = evalExpr e					`thenEV` \ e_eval ->
656
     case e_eval of
657
658
659
        "True"  -> returnEV True
        "False" -> returnEV False
        other   -> failEV (notABool other)