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
|
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 GenEq
import SmurfParse
derive gEq Stm
instance == Stm where == a b = a === b
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 toChar Stm where toChar stm = (toString stm).[0]
instance fromChar Stm
where
fromChar '"' = Push ""
fromChar 'i' = Input
fromChar 'o' = Output
fromChar '+' = Cat
fromChar 'h' = Head
fromChar 't' = Tail
fromChar 'q' = Quotify
fromChar 'p' = Put
fromChar 'g' = Get
fromChar 'x' = Exec
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]
|
