Newer
Older
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
module IMP where
-- A small imperative language
import Text.Read(readMaybe)
import Data.Maybe(mapMaybe)
import qualified Data.Map as Map
import Control.Monad.Identity
import Control.Monad.Except
import Control.Monad.State.Strict
import Control.Monad.Writer.Strict
import Absy
data St = St { mem :: Map.Map Var Int
, stdin :: [Int]
}
initialState :: [Int]-> St
initialState i = St Map.empty i
-- Exceptions
data Exn = BreakExn
| User String
| Error String
deriving Show
type Imp a = StateT St (WriterT [String] (ExceptT Exn Identity)) a
readVar :: Var-> Imp Int
readVar var = do
s<- get
case Map.lookup var (mem s) of
Just i -> return i
Nothing -> throwError (Error $ "Invalid variable access "++ var)
writeVar :: Var-> Int-> Imp ()
writeVar v w = modify $ \s-> s{mem = Map.insert v w (mem s)}
output :: String-> Int-> Imp ()
output msg i = tell [msg ++ show i]
input :: Imp Int
input = do
s<- get
case stdin s of
i:is -> do put $ s{stdin = is}
return i
[] -> throwError (Error $ "Premature EOF")
catch :: Imp ()-> (String-> Imp ())-> Imp ()
catch i handler =
i `catchError` \e-> case e of User str-> handler str; _ -> throwError e
-- Evaluate an expression.
liftBinOp :: (Int-> Int-> a)-> Expr-> Expr-> Imp a
liftBinOp f e1 e2 = do i1<- evalA e1; i2<- evalA e2; return $ f i1 i2
evalA :: Expr-> Imp Int
evalA (Num i) = return i
evalA (Var l) = readVar l
evalA (Plus e1 e2) = liftBinOp (+) e1 e2
evalA (Minus e1 e2) = liftBinOp (-) e1 e2
evalA (Times e1 e2) = liftBinOp (*) e1 e2
evalA (Mod e1 e2) = do v1 <- evalA e1
v2 <- evalA e2
when (v2 == 0) $ throwError (Error $ "Division by zero")
return $ v1 `mod` v2
evalA (Div e1 e2) = do v1 <- evalA e1
v2 <- evalA e2
when (v2 == 0) $ throwError (Error $ "Division by zero")
return $ v1 `div` v2
evalB :: BExpr -> Imp Bool
evalB BTrue = return True
evalB (Eq e1 e2) = liftBinOp (==) e1 e2
evalB (Less e1 e2) = liftBinOp (<) e1 e2
evalB (Not b) = do r<- evalB b; return (not r)
evalB (And b1 b2) = do r1<- evalB b1; r2<- evalB b2; return (r1 && r2)
evalB (Or b1 b2) = do r1<- evalB b1; r2<- evalB b2; return (r1 || r2)
eval :: Cmd-> Imp ()
eval (l := e) = do v<- evalA e; writeVar l v
eval (Block cs) = forM_ cs eval
eval (Print str e) = do i<- evalA e; output str i
eval (Read l) = do i<- input; writeVar l i
eval w@(While c i) =
do { b <- evalB c; if b then eval i >> eval w else return () }
`catchError` \e-> case e of BreakExn -> return (); _ -> throwError e
eval (If c p q) =
do b <- evalB c;
if b then eval p else eval q
eval Break = throwError BreakExn
eval (Throw exn) = throwError $ User exn
eval (Catch i handler) = eval i `catch` \s-> eval $ handler s
readLines :: IO [String]
readLines = do
s <- getLine
m <- if (null s) then return [] else readLines
return $ s: m
run :: Cmd-> IO ()
run i = do
putStrLn "Please provide input (one number per line, end with empty line):"
l <- readLines
let ints= mapMaybe readMaybe l
let ws = runStateT (eval i) (initialState ints)
let out = execWriterT ws
case runExcept out of
Left ex -> putStrLn $ "*** ERROR: " ++ show ex
Right o -> putStr (unlines o)