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
|
implementation module Smurf
from StdFunc import o, flip
import StdArray
import StdList
import StdString
import StdTuple
import StdFile
from Data.Func import $
import Control.Applicative
import Control.Monad
import Data.Maybe
import SmurfParse
instance zero [a] where zero = []
instance toString Stm
where
toString (Push s) = "\"" +++ s +++ "\""
toString Input = "i"
toString Output = "o"
toString Cat = "+"
toString Head = "h"
toString Tail = "t"
toString Quotify = "q"
toString Put = "p"
toString Get = "g"
toString Exec = "x"
instance zero State where zero = { stack = zero, store = zero }
instance toString State
where
toString {stack, store}
= "Stack:\n"
+++ foldl (+++) "" [" " +++ val +++ "\n" \\ val <- stack]
+++ "Store:\n"
+++ foldl (+++) "" [" " +++ var +++ " : " +++ val +++ "\n"
\\ (var, val) <- store]
run :: !Program State *File -> *(Maybe State, *File)
run prog st io
# (mbProgSt, io) = step prog st io
| isNothing mbProgSt = (Nothing, io)
# (prog, st) = fromJust mbProgSt
= if (isEmpty prog) (Just st, io) (run prog st io)
step :: !Program State !*File -> *(Maybe (!Program, State), *File)
step [] st io
= (pure ([], st), io)
step [Push s:p] st io
= (pure (p, { st & stack = push s st.stack }), io)
step [Input:p] st io
# (ip, io) = freadline io
# ip = ip % (0, size ip - 2)
= (pure (p, { st & stack = push ip st.stack }), io)
step [Output:p] st io
# mbSStk = pop st.stack
| isNothing mbSStk = (empty, io)
# (s, stk) = fromJust mbSStk
= (pure (p, { st & stack = stk }), io <<< s)
step [Cat:p] st io
= (pop st.stack >>= \(x,stk) -> pop stk >>= \(y,stk`) ->
pure (p, { st & stack = push (y +++ x) stk` }), io)
step [Head:p] st io
= (pop st.stack >>= \(x,stk) -> head x >>= \x` ->
pure (p, { st & stack = push x` stk }), io)
step [Tail:p] st io
= (pop st.stack >>= \(x,stk) -> tail x >>= \x` ->
pure (p, { st & stack = push x` stk }), io)
step [Quotify:p] st io
= (pop st.stack >>= \(x,stk) ->
pure (p, { st & stack = push (quotify x) stk }), io)
step [Put:p] st io
= (pop st.stack >>= \(var,stk) -> pop stk >>= \(val,stk`) ->
pure (p, { st & stack = stk`, store = put var val st.store }), io)
step [Get:p] st io
= (pop st.stack >>= \(var,stk) ->
pure (p, { st & stack = push (get var st.store) stk }), io)
step [Exec:p] st io
= (pop st.stack >>= parse o fromString o fst >>= \p ->
pure (p, zero), io)
push :: String Stack -> Stack
push s st = [s:st]
pop :: Stack -> Maybe (String, Stack)
pop [] = empty
pop [s:ss] = pure (s, ss)
head :: String -> Maybe String
head "" = empty
head s = pure $ s % (0,0)
tail :: String -> Maybe String
tail "" = empty
tail s = pure $ s % (1, size s - 1)
put :: String String Store -> Store
put var val store = [(var,val) : filter ((<>)var o fst) store]
get :: String Store -> String
get var store = case filter ((==)var o fst) store of [] = ""; [(_,val):_] = val
quotify :: (String -> String)
quotify = (flip (+++) "\"") o ((+++)"\"") o toString o quot o fromString
where
quot :: [Char] -> [Char]
quot [] = []
quot ['\\':cs] = ['\\':'\\':quot cs]
quot ['\n':cs] = ['\\':'n':quot cs]
quot ['\r':cs] = ['\\':'r':quot cs]
quot ['\t':cs] = ['\\':'t':quot cs]
quot ['"':cs] = ['\\':'"':quot cs]
quot [c:cs] = [c:quot cs]
|
