1 | (use srfi-1) |
---|
2 | |
---|
3 | (define *undefined* (if #f #f)) |
---|
4 | |
---|
5 | (define (tagged? tag obj) (and (pair? obj) (eq? (car obj) tag))) |
---|
6 | (define (tagged?$ tag) (lambda (obj) (and (pair? obj) (eq? (car obj) tag)))) |
---|
7 | (define (tag t obj) (cons t obj)) |
---|
8 | (define (tag$ t) (lambda (obj) (cons t obj))) |
---|
9 | (define (untag obj) (cdr obj)) |
---|
10 | |
---|
11 | (use peg) |
---|
12 | |
---|
13 | (define (nil-if-true l) (if (eq? #t l) '() l)) |
---|
14 | (define ($my-sep-by parse sep . args) |
---|
15 | ($do (them ($sep-by parse sep)) |
---|
16 | ($return (nil-if-true them)))) |
---|
17 | |
---|
18 | (define %ws ($many ($one-of #[ \t\r\n]))) |
---|
19 | |
---|
20 | (define %string ; scheme-string で代用 |
---|
21 | (let* ([%dquote ($char #\")] |
---|
22 | [%unescaped ($none-of #[\"])] |
---|
23 | [%body-char ($or %unescaped)] |
---|
24 | [%string-body ($do (chars ($many %body-char)) |
---|
25 | ($return (tag :string (list->string chars))))] |
---|
26 | ) |
---|
27 | ($between %dquote %string-body %dquote))) |
---|
28 | |
---|
29 | (define %ident ;; scheme-symbolで代用 |
---|
30 | (let* ([%ident-head-char ($one-of #[a-z_])] |
---|
31 | [%ident-rest-char ($one-of #[0-9A-Za-z_'])]) |
---|
32 | ($do (head %ident-head-char) |
---|
33 | (rest ($many %ident-rest-char)) |
---|
34 | ($return (string->symbol (list->string (cons head rest))))))) |
---|
35 | |
---|
36 | (define %digits |
---|
37 | ($do (d ($many digit 1)) |
---|
38 | ($return (tag :number (string->number (list->string d)))))) |
---|
39 | |
---|
40 | (define %list |
---|
41 | (let* ([%begin-list ($seq %ws ($char #\[) %ws)] |
---|
42 | [%end-list ($seq %ws ($char #\]) %ws)] |
---|
43 | [%item ($or %digits %string %ident)] |
---|
44 | [%item-separator ($seq %ws ($char #\,) %ws)] |
---|
45 | ) |
---|
46 | ($do %begin-list |
---|
47 | (items ($my-sep-by %item %item-separator)) |
---|
48 | %end-list |
---|
49 | ($return (tag :list items))) |
---|
50 | )) |
---|
51 | |
---|
52 | (define %tuple |
---|
53 | (let* ([%begin-list ($seq %ws ($char #\() %ws)] |
---|
54 | [%end-list ($seq %ws ($char #\)) %ws)] |
---|
55 | [%item ($or %digits %string %ident)] |
---|
56 | [%item-separator ($seq %ws ($char #\,) %ws)] |
---|
57 | ) |
---|
58 | ($do %begin-list |
---|
59 | (items ($my-sep-by %item %item-separator)) |
---|
60 | %end-list |
---|
61 | ($return (tag :tuple @items))) |
---|
62 | )) |
---|
63 | |
---|
64 | (define %expr |
---|
65 | ($or %string %digits %ident %list %tuple)) |
---|
66 | |
---|
67 | (define %application |
---|
68 | (let1 %an-application |
---|
69 | ($do (fn %ident) |
---|
70 | %ws |
---|
71 | (args ($my-sep-by %expr %ws)) |
---|
72 | ($return `(:apply ,fn ,@args))) |
---|
73 | ($do (app1 %an-application) |
---|
74 | (apps ($many ($do %ws |
---|
75 | (($char #\$)) |
---|
76 | %ws |
---|
77 | (app %an-application) |
---|
78 | ($return app)))) |
---|
79 | ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps)))))) |
---|
80 | |
---|
81 | (define %haskell |
---|
82 | (let* ([%unknown ($my-sep-by %expr %ws)] |
---|
83 | |
---|
84 | [%assignment ($do (id %ident) |
---|
85 | %ws |
---|
86 | (($string "<-")) |
---|
87 | %ws |
---|
88 | (value %application) |
---|
89 | ($return `(:assign ,id ,value)) |
---|
90 | )] |
---|
91 | [%do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws)] |
---|
92 | [%do ($do (($string "do")) |
---|
93 | %ws |
---|
94 | (exprs ($or ($between ($seq ($char #\{) %ws) |
---|
95 | ($my-sep-by ($or %assignment %application) |
---|
96 | ($seq %ws ($char #\;) ($optional ($seq newline ($string " "))) %ws)) |
---|
97 | ($seq %ws ($char #\}))) |
---|
98 | ($my-sep-by ($or %assignment %application) |
---|
99 | ($seq newline ($string " ") %ws)) )) |
---|
100 | ($return `(:do ,@exprs)))] |
---|
101 | |
---|
102 | [%defun ($do (id %ident) |
---|
103 | %ws |
---|
104 | (args ($my-sep-by %ident %ws)) |
---|
105 | %ws |
---|
106 | (($char #\=)) |
---|
107 | %ws |
---|
108 | (rightside ($or %do %application)) |
---|
109 | ($return `(:defun (,id ,@args) ,rightside)) |
---|
110 | )] |
---|
111 | [%pattern ($do (id %ident) |
---|
112 | %ws |
---|
113 | (args ($my-sep-by ($or %ident %digits) %ws)) |
---|
114 | %ws |
---|
115 | (($char #\=)) |
---|
116 | %ws |
---|
117 | (rightside ($or %do %application)) |
---|
118 | ($return `(:pattern (,id ,@args) ,rightside)) |
---|
119 | )] |
---|
120 | |
---|
121 | ) |
---|
122 | ($or %defun %pattern %assignment %application %expr |
---|
123 | %unknown) |
---|
124 | )) |
---|
125 | |
---|
126 | (define (parse-haskell str) |
---|
127 | (parse-string %haskell str)) |
---|
128 | |
---|
129 | (define putStrLn print) |
---|
130 | |
---|
131 | (define ident? symbol?) |
---|
132 | (define ident-body identity) |
---|
133 | ;(define ident? (tagged?$ :ident)) |
---|
134 | ;(define ident-body untag) |
---|
135 | |
---|
136 | (define (indent w lines) |
---|
137 | (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line))) |
---|
138 | lines) |
---|
139 | "\n")) |
---|
140 | |
---|
141 | (define *namespace* (make-hash-table)) |
---|
142 | (define (assign id val) |
---|
143 | (hash-table-put! *namespace* id val) |
---|
144 | id) |
---|
145 | (define (lookup id) |
---|
146 | (let1 val (hash-table-get *namespace* id) |
---|
147 | ; |
---|
148 | val)) |
---|
149 | |
---|
150 | ;; |
---|
151 | (define (make-procedure params body env) |
---|
152 | (list :procedure params body env)) |
---|
153 | |
---|
154 | (use util.match) |
---|
155 | (define (heval-map exps env) (map (cut heval <> env) exps)) |
---|
156 | (define (heval exp env) |
---|
157 | (if (or (null? exp) (not (pair? exp))) *undefined* |
---|
158 | (match exp |
---|
159 | [(':$ . _) |
---|
160 | ; (delay-it |
---|
161 | (let loop ([rest (cdr exp)]) |
---|
162 | (if (null? (cdr rest)) |
---|
163 | (heval (car rest) env) |
---|
164 | (heval (append (car rest) (list (loop (cdr rest)))) env) |
---|
165 | )) |
---|
166 | ; env) |
---|
167 | ] |
---|
168 | [(':apply f . _) |
---|
169 | (if (null? (cddr exp)) |
---|
170 | ; (delay-it (list (ident-body f)) env) |
---|
171 | (list (ident-body f)) |
---|
172 | `(,(ident-body f) ,@(cddr exp)); ,@(map (cut heval <> env) (cdr exp))) |
---|
173 | ; (delay-it `(,(ident-body f) |
---|
174 | ; ,@(map (cut heval <> env) (cdr exp))) |
---|
175 | ; env) |
---|
176 | )] |
---|
177 | [(':assign x y) ; id <- action |
---|
178 | (assign (ident-body x) (heval y env))] |
---|
179 | [(':do . _) ; do { ... ; ... ; ... } |
---|
180 | `(seq ,@(heval-map (cdr exp) env))] |
---|
181 | [(':defun id definition) ; id x y z = app x $ app y $ app z |
---|
182 | (let ([ident (car id)] |
---|
183 | [args (cdr id)]) |
---|
184 | (assign (ident-body ident) |
---|
185 | (make-procedure (map ident-body args) ;lambda-parameters |
---|
186 | (if (eq? 'seq (car definition)) ; lambda-body |
---|
187 | (heval definition env) |
---|
188 | (list (heval definition env)) ) |
---|
189 | env)))] |
---|
190 | [(':pattern id definition) ; id x y z = app x $ app y $ app z |
---|
191 | (let ([ident (car id)] |
---|
192 | [args (cdr id)]) |
---|
193 | (assign (ident-body ident) |
---|
194 | (make-procedure (map ident-body args) ;lambda-parameters |
---|
195 | (if (eq? 'seq (car definition)) ; lambda-body |
---|
196 | (heval definition env) |
---|
197 | (list (heval definition env)) ) |
---|
198 | env)))] |
---|
199 | |
---|
200 | [(':string . str) str] |
---|
201 | [(':list . l) l] |
---|
202 | [(':tuple . t) t] |
---|
203 | [(':ident . id) id] |
---|
204 | |
---|
205 | [_ (if (pair? exp) (happly (car exp) (cdr exp)) |
---|
206 | (format "unknown: ~a" exp))] ))) |
---|
207 | |
---|
208 | (define (primitive-procedure? proc) |
---|
209 | (memq proc '(putStr |
---|
210 | putStrLn |
---|
211 | lines length print |
---|
212 | tail))) |
---|
213 | |
---|
214 | (define (prim-print exp) |
---|
215 | (define (haskell-description-of-list l) |
---|
216 | (string-append "[" (string-join (map haskell-description l) ",") "]")) |
---|
217 | |
---|
218 | (define (haskell-description obj) |
---|
219 | (cond [(not (pair? obj)) (x->string obj)] |
---|
220 | [(tagged? :number obj) (number->string (untag obj))] |
---|
221 | [(tagged? :string obj) (untag obj)] |
---|
222 | [(tagged? :list obj) ; (untag obj)] |
---|
223 | (list->haskell-string (untag obj))] |
---|
224 | [(pair? obj) (haskell-description-of-list obj)] |
---|
225 | [else (x->string obj)])) |
---|
226 | |
---|
227 | (print (haskell-description exp))) |
---|
228 | |
---|
229 | (define (prim-tail exp) |
---|
230 | (cond [(tagged? :string exp) (substring (cdr exp) 1 (string-length (cdr exp)))] |
---|
231 | [(tagged? :list exp) (cddr exp)] |
---|
232 | [(pair? exp) (cdr exp)] |
---|
233 | [else *undefined*])) |
---|
234 | |
---|
235 | (define (apply-primitive-procedure proc args) |
---|
236 | (let1 args* (heval-map args '()) |
---|
237 | (case proc |
---|
238 | ((putStr) (display (x->string (car args*)))) |
---|
239 | ((putStrLn) (apply prim-print args*)) |
---|
240 | ((print) (apply prim-print args*)) |
---|
241 | ((lines) (length args*)) |
---|
242 | ((length) (if (tagged? :string (car args*)) |
---|
243 | (string-length (car args*)) |
---|
244 | (length (car args*)))) |
---|
245 | ((tail) (prim-tail (car args*))) |
---|
246 | ))) |
---|
247 | |
---|
248 | (define (compound-procedure? proc) (tagged? :procedure proc)) |
---|
249 | |
---|
250 | (define (procedure-parameters proc) (second proc)) |
---|
251 | (define (procedure-body proc) (third proc)) |
---|
252 | (define (procedure-environment proc) (fourth proc)) |
---|
253 | |
---|
254 | (define (make-frame vars vals) (cons vars vals)) |
---|
255 | |
---|
256 | (define (extend-environment vars vals base-env) |
---|
257 | ;; assert-equal (length vars) (length vals) |
---|
258 | (cons (make-frame vars vals) base-env)) |
---|
259 | |
---|
260 | (define (happly proc args) |
---|
261 | (cond [(primitive-procedure? proc) |
---|
262 | (apply-primitive-procedure proc args)] |
---|
263 | [(compound-procedure? proc) |
---|
264 | (let1 env (extend-environment (procedure-parameters proc) |
---|
265 | args |
---|
266 | (procedure-environment proc)) |
---|
267 | (heval-map (procedure-body proc) env))] |
---|
268 | [else |
---|
269 | ; |
---|
270 | ])) |
---|
271 | |
---|
272 | ;; REPL |
---|
273 | (let repl () |
---|
274 | (let1 input (read-line) |
---|
275 | (if (eof-object? input) 'eof |
---|
276 | (let1 parsed (parse-haskell input); (haskell->scheme input) |
---|
277 | (let1 evaled (heval parsed '()) |
---|
278 | (print "> " input) |
---|
279 | (print "=> " parsed) |
---|
280 | (print "" evaled)) |
---|
281 | (repl))))) |
---|
282 | |
---|
283 | (define (actual-value exp); env) |
---|
284 | (force-it (heval exp '()))) |
---|
285 | |
---|
286 | (let1 main (lookup 'main) |
---|
287 | (print "----") |
---|
288 | (happly main '()) |
---|
289 | ) |
---|