Skip to content

Commit dd6c2cb

Browse files
b3b00b3b00
authored
Merge pull request #14 from b3b00/IO_Monad
refactor to use IO monad
2 parents c92a2f3 + 955ec67 commit dd6c2cb

File tree

5 files changed

+232
-180
lines changed

5 files changed

+232
-180
lines changed

‎parsec/Main.hs‎

Lines changed: 68 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -39,63 +39,79 @@ printHeap machine = do
3939
putStrLn ""
4040

4141

42-
action :: String -> String -> Stmt -> IO()
43-
action act out ast = case act of
44-
--"-run" -> (run ast)
45-
{- "-compile" -> do
46-
47-
let checked = semanticCheck ast in
48-
if length checked > 0 then
49-
putStrLn ("semantic chec failed "++(show checked))
50-
else
51-
let compiled = (compileAst ast (Machine 0 [] [] [] []) ) in
52-
putStrLn ("compilation suceeded : "++(show ast))-}
53-
"-compileAndRun" -> do
54-
let checked = semanticCheck ast in
55-
if length checked > 0 then
56-
putStrLn ("semantic chec failed "++(show checked))
57-
else
58-
let compiled = (compileAst ast (Machine 0 [] [] [] []) ) in
59-
let result = runIt compiled in
60-
do
61-
putStrLn "done :: "
62-
printHeap result
63-
"-compile" -> do
64-
let checked = semanticCheck ast in
65-
if length checked > 0 then
66-
putStrLn ("semantic chec failed "++(show checked))
67-
else
68-
let compiled = (compileAst ast (Machine 0 [] [] [] []) ) in
69-
let serialized = (show compiled) in
70-
do
71-
writeFile out serialized
72-
putStrLn ("compilation done to "++out)
73-
74-
"-i" -> do
42+
dispatch :: [(String, [String] -> IO ())]
43+
dispatch = [ ("-r", runBC)
44+
, ("-compile", compile)
45+
, ("-i", interprete)
46+
--, ("-compileAndRun", compileAndRun)
47+
]
48+
49+
{- run ByteCode -}
50+
runBC :: [String] -> IO()
51+
runBC args = do
52+
putStrLn "running..."
53+
readFile (args!!0) >>= runFile
54+
55+
56+
runFile :: String -> IO()
57+
runFile machineSerial = do
58+
let machine = read machineSerial
59+
result <- runIt machine
60+
putStrLn "done :: "
61+
printHeap result
62+
63+
{- compile to byetcode -}
64+
65+
compile :: [String] -> IO()
66+
compile args =
67+
do
68+
ast <- (parseFile (args!!0))
69+
let out = (args!!1)
70+
checked = semanticCheck ast
71+
if length checked > 0 then
72+
putStrLn ("semantic chec failed "++(show checked))
73+
else
74+
do
75+
let compiled = (compileAst ast (Machine 0 [] [] [] []) )
76+
serialized = (show compiled)
77+
writeFile out serialized
78+
putStrLn ("compilation done to "++out)
79+
80+
{-compileAndRun :: [String] -> IO()
81+
compileAndRun args =
82+
do
83+
ast <- (parseFile (args !! 0))
84+
putStrLn "to refactor something wrong here "
85+
let checked = semanticCheck ast in
86+
if length checked > 0 then
87+
putStrLn ("semantic chec failed "++(show checked))
88+
else
89+
let compiled = (compileAst ast (Machine 0 [] [] [] []) ) in
90+
result <- runIt compiled
91+
putStrLn "done :: "
92+
printHeap result-}
93+
94+
{- interprete -}
95+
interprete :: [String] -> IO()
96+
interprete args =
97+
do
98+
ast <- (parseFile (args!!0))
7599
let checked = semanticCheck ast in
76100
if length checked > 0 then
77-
putStrLn ("semantic chec failed "++(show checked))
101+
putStrLn ("semantic chec failed "++(show checked))
78102
else
79-
do
80-
run ast
103+
run ast
104+
105+
106+
107+
108+
81109

82-
runFile :: String -> IO()
83-
runFile machineSerial = do
84-
let machine = read machineSerial in
85-
let result = runIt machine in
86-
do
87-
putStrLn "done :: "
88-
printHeap result
89110
main = do
90-
args <- getArgs
91-
case (args!!0) of
92-
"-run" -> do
93-
putStrLn "running..."
94-
readFile (args!!1) >>= runFile
95-
putStrLn ("deserialize and run "++(args!!1))
96-
otherwise -> do
97-
putStrLn "generic AST action"
98-
(parseFile (args!!1)) >>= action (args !! 0) (args!!2)
111+
(command:args) <- getArgs
112+
putStrLn ("MAIN :: "++command++" // "++(show args))
113+
let (Just action) = lookup command dispatch
114+
action args
99115

100116

101117
tac = unlines . reverse . lines

‎parsec/Runner.hs‎

Lines changed: 48 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -54,25 +54,25 @@ aBinOpFunction op = case op of
5454

5555

5656

57-
aBinaryOp :: Machine -> Int -> (Int -> Int -> Int) -> Machine
57+
aBinaryOp :: Machine -> Int -> (Int -> Int -> Int) -> IO Machine
5858
aBinaryOp machine opcode op =
5959
let popped = (doublePopValue (stack machine)) in
6060
let newStack = (snd popped) in
6161
let x = (snd (fst popped)) in
6262
let y = (fst (fst popped)) in
6363
let res = ( op (getIntValue (x)) (getIntValue (y)) ) in
6464
let appendedStack = pushValue newStack (IntVal res) in
65-
Machine ((pointer machine)+1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine)
65+
do return $ (Machine ((pointer machine)+1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine))
6666

6767

68-
aNegOp :: Machine -> Machine
68+
aNegOp :: Machine -> IO Machine
6969
aNegOp machine =
7070
let popped = popValue (stack machine) in
7171
let newStack = (snd popped) in
7272
let v = (getIntValue (fst popped)) in
7373
let negV = 0 - v in
7474
let appendedStack = (pushValue newStack (IntVal negV)) in
75-
(Machine ((pointer machine ) +1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine))
75+
do return $ (Machine ((pointer machine ) +1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine))
7676

7777
{- ********************************
7878
@@ -93,37 +93,37 @@ bBinOpFunction op = case op of
9393

9494

9595

96-
bBinaryOp :: Machine -> Int -> (Bool -> Bool -> Bool) -> Machine
96+
bBinaryOp :: Machine -> Int -> (Bool -> Bool -> Bool) -> IO Machine
9797
bBinaryOp machine opcode op =
9898
let popped = (doublePopValue (stack machine)) in
9999
let newStack = (snd popped) in
100100
let x = (snd (fst popped)) in
101101
let y = (fst (fst popped)) in
102102
let res = ( op (getBoolValue (x)) (getBoolValue (y)) ) in
103103
let appendedStack = pushValue newStack (BoolVal res) in
104-
Machine ((pointer machine)+1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine)
104+
do return $ (Machine ((pointer machine)+1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine))
105105

106106

107107

108-
bNotOp :: Machine -> Machine
108+
bNotOp :: Machine -> IO Machine
109109
bNotOp machine =
110110
let popped = popValue (stack machine) in
111111
let newStack = (snd popped) in
112112
let v = (getBoolValue (fst popped)) in
113113
let appendedStack = pushValue newStack (BoolVal v) in
114-
(Machine ((pointer machine ) +1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine))
114+
do return $ (Machine ((pointer machine ) +1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine))
115115

116116

117117

118-
rBinaryOp :: Machine -> Int -> (Int -> Int -> Bool) -> Machine
118+
rBinaryOp :: Machine -> Int -> (Int -> Int -> Bool) -> IO Machine
119119
rBinaryOp machine opcode op =
120120
let popped = (doublePopValue (stack machine)) in
121121
let newStack = (snd popped) in
122122
let x = (snd (fst popped)) in
123123
let y = (fst (fst popped)) in
124124
let res = ( op (getIntValue (x)) (getIntValue (y)) ) in
125125
let appendedStack = pushValue newStack (BoolVal res) in
126-
Machine ((pointer machine)+1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine)
126+
do return $ (Machine ((pointer machine)+1) (bytecode machine) appendedStack (heap machine) (heapAddresses machine))
127127

128128

129129

@@ -135,7 +135,7 @@ rBinaryOp machine opcode op =
135135
136136
******************************** -}
137137

138-
movOp :: Machine -> Machine
138+
movOp :: Machine -> IO Machine
139139

140140
movOp machine =
141141
let debug = 1 in
@@ -144,67 +144,71 @@ movOp machine =
144144
let bcaddr = (opCodeRel machine 1) in
145145
let newheap = setInHeap (bcaddr) value (heap machine) in
146146
let newStack = (snd popped) in
147-
Machine ((pointer machine)+2) (bytecode machine) newStack newheap (heapAddresses machine)
147+
do return $ (Machine ((pointer machine)+2) (bytecode machine) newStack newheap (heapAddresses machine))
148148

149-
pushOp :: Machine -> Machine
149+
pushOp :: Machine -> IO Machine
150150
pushOp machine =
151151
let debug = 1 in
152152
let k = ((pointer machine)+1) in
153153
let addr = ((bytecode machine) !! (k)) in
154154
let value = (heap machine) !! (addr) in
155155
let newStack = pushValue (stack machine) value in
156-
(Machine ((pointer machine)+2) (bytecode machine) newStack (heap machine) (heapAddresses machine))
156+
do return $ (Machine ((pointer machine)+2) (bytecode machine) newStack (heap machine) (heapAddresses machine))
157157

158-
printOp :: Machine -> Machine
158+
printOp :: Machine -> IO Machine
159159
printOp machine =
160160
let popped = popValue (stack machine) in
161161
let newStack = (snd popped) in
162162
let value = (fst popped) in
163-
trace ("PRINT "++(show value)) (Machine ((pointer machine) +1) (bytecode machine) newStack (heap machine) (heapAddresses machine))
163+
do
164+
putStrLn ("PRINT "++(show value))
165+
return $ ((Machine ((pointer machine) +1) (bytecode machine) newStack (heap machine) (heapAddresses machine)))
164166

165-
noOp :: Machine -> Machine
166-
noOp machine = Machine ((pointer machine) +1) (bytecode machine) (stack machine) (heap machine) (heapAddresses machine)
167167

168+
noOp :: Machine -> IO Machine
169+
noOp machine = do return $ (Machine ((pointer machine) +1) (bytecode machine) (stack machine) (heap machine) (heapAddresses machine))
168170

169171

170172

171173

172-
unconditionalJump :: Machine -> Machine
174+
175+
unconditionalJump :: Machine -> IO Machine
173176
unconditionalJump machine = let dest = opCodeRel machine 1 in
174-
Machine dest (bytecode machine) (stack machine) (heap machine) (heapAddresses machine)
177+
do return $ (Machine dest (bytecode machine) (stack machine) (heap machine) (heapAddresses machine))
175178

176-
jumpIfTrue :: Machine -> Machine
179+
jumpIfTrue :: Machine -> IO Machine
177180
jumpIfTrue machine = let dest = opCodeRel machine 1 in
178181
let popped = popValue (stack machine) in
179182
if (fst popped) == (BoolVal True) then
180-
Machine dest (bytecode machine) (stack machine) (heap machine) (heapAddresses machine)
183+
do return $ (Machine dest (bytecode machine) (stack machine) (heap machine) (heapAddresses machine))
181184
else
182-
Machine ((pointer machine)+2) (bytecode machine) (stack machine) (heap machine) (heapAddresses machine)
185+
do return $ (Machine ((pointer machine)+2) (bytecode machine) (stack machine) (heap machine) (heapAddresses machine))
183186

184-
jumpIfNotTrue :: Machine -> Machine
187+
jumpIfNotTrue :: Machine -> IO Machine
185188
jumpIfNotTrue machine = let dest = opCodeRel machine 1 in
186189
let popped = popValue (stack machine) in
187190
if (fst popped) == (BoolVal False) then
188-
Machine dest (bytecode machine) (snd popped) (heap machine) (heapAddresses machine)
191+
do return $ (Machine dest (bytecode machine) (snd popped) (heap machine) (heapAddresses machine))
189192
else
190-
Machine ((pointer machine)+2) (bytecode machine) (snd popped) (heap machine) (heapAddresses machine)
193+
do return $ (Machine ((pointer machine)+2) (bytecode machine) (snd popped) (heap machine) (heapAddresses machine))
191194

192195
{- ********************************
193196
194197
ENTRY POINT
195198
196199
******************************** -}
197200

198-
runIt :: Machine -> Machine
201+
runIt :: Machine -> IO Machine
199202

200203
runIt machine
201-
| (pointer machine) >= (length (bytecode machine)) = machine
204+
| (pointer machine) >= (length (bytecode machine)) = do
205+
return machine
202206
| otherwise = runIt' machine
203207

204208

205209

206210

207-
genericOpCodeFunctions :: Int -> (Machine -> Machine)
211+
genericOpCodeFunctions :: Int -> (Machine -> IO Machine)
208212
genericOpCodeFunctions opcode = case opcode of
209213
1 -> pushOp
210214
3 -> movOp
@@ -219,25 +223,33 @@ genericOpCodeFunctions opcode = case opcode of
219223

220224

221225

222-
runIt' :: Machine -> Machine
226+
runIt' :: Machine -> IO Machine
223227
runIt' machine
224228
| (opCodeIn machine [1,3,8,9,15,16,17,18,19]) =
225229
let opCodeFunction = (genericOpCodeFunctions (opCode machine)) in
226230
let opIt= opCodeFunction machine in
227-
runIt opIt
231+
do
232+
machine <- opIt
233+
runIt machine
228234
| (opCodeIn machine [4..7]) =
229235
let opIt = (aBinaryOp machine (opCode machine) (aBinOpFunction (opCode machine))) in
230-
runIt opIt
236+
do
237+
machine <- opIt
238+
runIt machine
231239
| (opCodeIn machine [10,11]) =
232240
let opIt = (bBinaryOp machine (opCode machine) (bBinOpFunction (opCode machine))) in
233-
runIt opIt
241+
do
242+
machine <- opIt
243+
runIt machine
234244
| (opCodeIn machine [12,14]) =
235245
let opIt = (rBinaryOp machine (opCode machine) (rBinOpFunction (opCode machine))) in
236-
runIt opIt
237-
| otherwise = Machine (-1) [] [] [] []
246+
do
247+
machine <- opIt
248+
runIt machine
249+
| otherwise = do return $ Machine (-1) [] [] [] []
238250

239251

240-
runMachine :: Machine -> Machine
252+
runMachine :: Machine -> IO Machine
241253
runMachine machine = runIt machine
242254

243255

0 commit comments

Comments
 (0)