~williewillus/r16

ref: 5bcb0d0945d41b62bb1aec10b43323b8b0244f90 r16/evaluator.rkt -rw-r--r-- 13.0 KiB
5bcb0d09 — eutro Fix recursive calls within recursive calls using the same namespace 2 months ago
                                                                                
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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
#lang racket

(require racket/contract racket/sandbox syntax/strip-context threading)

(provide
 definitions?
 run-result?
 (contract-out
  [run (string? definitions? predicate/c . -> . run-result?)]
  [run-result-stdout (run-result? . -> . string?)]
  [run-result-stderr (run-result? . -> . (or/c non-empty-string? #f))]
  [run-result-results (run-result? . -> . (listof any/c))]
  [run-result (string? (or/c non-empty-string? #f) (listof any/c) . -> . run-result?)]))

(define definitions? (cons/c (listof (cons/c symbol? any/c))
                             (listof module-path?)))

(define recursive-sandbox-call? (make-parameter #f))

(define (unique-sym name)
  (string->uninterned-symbol (symbol->string name)))

;; in case it gets overridden, though sandbox-lib doesn't actually take this precaution
;; https://github.com/racket/racket/blob/6901f8d5511fd45516aa0a85ae070292e64226cc/pkgs/sandbox-lib/racket/sandbox.rkt#L705
(define ev
  (let ([eval-f (current-eval)])
    (lambda (expr)
      (parameterize ([current-eval eval-f])
        (eval expr)))))

(define (make-module-namespace name)
  (define sym (unique-sym name))
  (ev `(module ,sym racket))
  (dynamic-require `',sym #f)
  (module->namespace `',sym))

(define (init-evaluator)
  (parameterize ([sandbox-output 'string]
                 [sandbox-error-output 'string]
                 [sandbox-eval-limits '(30 20)]
                 [sandbox-propagate-exceptions #f]
                 [sandbox-make-environment-variables make-environment-variables])
    (make-evaluator 'racket)))

(define (code->exprs code)
  (define port (open-input-string code))
  (port-count-lines! port)
  (parameterize ([read-accept-lang #t] [read-accept-reader #t])
    (sequence->list (in-producer read-syntax eof 'trick port))))

(struct run-result (stdout stderr results) #:transparent)

(define (run code definitions pass-out?)
  (define (run-evaluation)
    ;; read and evaluate the code, yielding the results to be passed out
    ;; (to be called in the sandbox context)

    (recursive-sandbox-call? #t)

    (define exprs (code->exprs code))

    (define (not-module)
      ;; introduce definitions into the namespace dynamically
      (for ([mod (in-list (cdr definitions))])
        (namespace-require mod))
      (for ([def (in-list (car definitions))])
        (namespace-set-variable-value! (car def) (cdr def) #t))

      ;; evaluate `(begin exprs ...)' repl-style
      (if (null? exprs)
          null
          (let loop ([exprs exprs])
            (define expr #`(#%top-interaction . #,(car exprs)))
            (if (null? (cdr exprs))
                (call-with-values (thunk (ev expr)) list)
                (begin
                  (ev expr)
                  (loop (cdr exprs)))))))

    ;; there are two options for evaluating the code:
    ;; - the code is a series of top level expressions:
    ;;   - in this case, just evaluate them like `(begin exprs ...)'
    ;;     see `not-module' above
    ;; - the code is a module:
    ;;   - this case is a bit more complicated, since we want
    ;;     r16 definitions as well, see below
    (define raw-results
      (call/cc
       (lambda (return)
         ;; sorry for the imperative-style return
         (unless (= (length exprs) 1) (return (not-module)))

         (define (literal-identifier=? a b) ;; to match `module' better
           (or (free-identifier=? a b)
               (eq? (syntax-e a) (syntax-e b))))

         (syntax-case* (car exprs) (module) literal-identifier=?
           [(module modname lang body ...)
            (identifier? #'modname)
            (let ()
              (define varnames (map car (car definitions)))
              (define (eval-quote form) (cons '#%datum form))
              (define varvals (map (compose eval-quote cdr) (car definitions)))
              (define modules (cdr definitions))
              (define sandbox-language (unique-sym 'sandbox-language))
              (define modname-sym (unique-sym (syntax-e #'modname)))
              (define module-name (datum->syntax #'modname modname-sym))
              ;; define a module that provides all of the sandbox definitions
              ;; in addition to those of the requested lang
              (ev #`(module #,sandbox-language racket/base
                      ;; require and provide any defined modules
                      (provide (all-from-out #,@modules))
                      (require #,@modules)

                      ;; define and provide any defined variables
                      (provide #,@varnames)
                      (define-values (#,@varnames) (values #,@varvals))

                      ;; require and provide the lang of the module that was read
                      (#%provide (all-from lang))
                      (require lang)))

              ;; then evaluate the module with the new language
              (define trick-module
                #`(module #,module-name '#,sandbox-language
                    body ...))
              (ev (replace-context trick-module trick-module))

              ;; to actually pass any values out, `r16-main' can be provided,
              ;; otherwise the module is just instantiated for side-effects

              (define qmodname (list 'quote modname-sym))

              (define main
                (dynamic-require
                 qmodname 'r16-main
                 (thunk (dynamic-require qmodname #f))))

              (if (and (procedure? main)
                       (procedure-arity-includes? main 0))
                  (call-with-values main list)
                  (list main)))]

           [_ (not-module)]))))

    (define (pass-out-results results)
      (for/list ([result (in-list results)]
                 #:when (not (void? result)))
        (if (pass-out? result)
            result
            (~a result))))

    (apply values (pass-out-results raw-results)))

  (define-values (stdout results stderr)
    (if (recursive-sandbox-call?)
        (let ()
          (define stdout-port (open-output-string))
          (define stderr-port (open-output-string))
          (define results
            (parameterize ([current-output-port stdout-port]
                           [current-error-port stderr-port]
                           [current-namespace (make-module-namespace 'recursive-trick)])
              (call-with-values run-evaluation list)))
          (values (get-output-string stdout-port)
                  results
                  (get-output-string stderr-port)))

        (let ()
          (define evaluator (init-evaluator))
          (define results
            (~> (thunk (call-in-sandbox-context evaluator run-evaluation))
                (call-with-values _ list)
                ;; call-in-sandbox-context returns void if there's an exception
                (filter-not void? _)))
          (define stdout (get-output evaluator))
          (define stderr (get-error-output evaluator))
          (kill-evaluator evaluator)
          (values stdout results stderr))))

  (run-result stdout (and (non-empty-string? stderr) stderr) results))

(module+ test
  (require rackunit)

  (define empty-defs '(()))
  (define (any? _ignored) #t)

  (test-case "Empty Test"
    (check-equal?
     (run "" empty-defs any?)
     (run-result "" #f '())))

  (test-case "Single Expr Test"
    (check-equal?
     (run "1" empty-defs any?)
     (run-result "" #f '(1)))
    (check-equal?
     (run (~s `(+ 1 2)) empty-defs any?)
     (run-result "" #f '(3)))
    (check-equal?
     (run (~s `(values 1 2 3)) empty-defs any?)
     (run-result "" #f '(1 2 3))))

  (test-case "Multiple Expr Test"
    (check-equal?
     (run "1 2 3" empty-defs any?)
     (run-result "" #f '(3)))
    (check-equal?
     (run (~s '(define x 100)
              'x)
          empty-defs any?)
     (run-result "" #f '(100))))

  (test-case "Stdio Test"
    (check-equal?
     (run (~s `(display "stdout test"))
          empty-defs any?)
     (run-result "stdout test" #f '()))
    (check-equal?
     (run (~s `(display "stderr test" (current-error-port)))
          empty-defs any?)
     (run-result "" "stderr test" '())))

  (test-case "Module Test"
    (check-equal?
     (run (~s `(module test racket
                 1
                 2
                 3))
          empty-defs any?)
     (run-result "1\n2\n3\n" #f '()))
    (check-equal?
     (run "#lang racket\
           1 2 3"
          empty-defs any?)
     (run-result "1\n2\n3\n" #f '()))
    (check-equal?
     (run (string-append
           "#lang racket\n"
           (~s `(provide r16-main)
               `(define r16-main 100)))
          empty-defs any?)
     (run-result "" #f '(100)))
    (check-equal?
     (run (string-append
           "#lang racket\n"
           (~s `(provide r16-main)
               `(define (r16-main) (values 1 2 3))))
          empty-defs any?)
     (run-result "" #f '(1 2 3))))

  (test-case "Binding Test"
    (define xv (box "box"))
    (let ()
      (define rr (run "x" `(((x . ,xv))) any?))
      (check-false (run-result-stderr rr))
      (check-equal? (~> rr run-result-results car) xv))
    (let ()
      (define rr
        (run (~s `(module test racket
                    (provide r16-main)
                    (define (r16-main) x)))
             `(((x . ,xv))) any?))
      (check-false (run-result-stderr rr))
      ;; not necessarily eq? unfortunately
      (check-equal? (~> rr run-result-results car) xv)))

  (define ((run-fn defs) expr)
    (define rr (run expr defs any?))
    (display (run-result-stdout rr))
    (cond [(run-result-stderr rr)
           => (lambda (stderr) (display stderr (current-error-port)))])
    (apply values (run-result-results rr)))

  (test-case "Recursive Call Test"
    (check-equal?
     (run (~s `(run (~s `(+ 1 2 3))))
          `(((run . ,(run-fn empty-defs))))
          any?)
     (run-result "" #f '(6))))

  (require racket/draw)

  (test-case "Reused Instantation Test"
    ;; bitmap% IN the sandbox is still different to that outside
    (check-false
     (~> (run
          (~s `(require racket/draw)
              `(make-bitmap 1 1))
          empty-defs
          any?)
         run-result-results
         car
         (is-a? _ bitmap%)))

    (check-equal?
     (run
      (~s `(require racket/draw)
          `(define bmp
             (run (~s `(require racket/draw)
                      `(make-bitmap 1 1))))
          `(is-a? bmp bitmap%))
      `(((run . ,(run-fn empty-defs))))
      any?)
     (run-result "" #f '(#t)))

    (check-equal?
     (run
      (~s `(require racket/draw)
          `(define bmp
             (run (~s `(require racket/draw)
                      `(run (~s `(require racket/draw)
                                `(make-bitmap 1 1))))))
          `(is-a? bmp bitmap%))
      `(((run . ,(run-fn `(((run . ,(run-fn empty-defs))))))))
      any?)
     (run-result "" #f '(#t))))

  (test-case "Namespace Hygiene Test"
    (check-equal?
     (run (~s `(define x 'x-value)
              `(foil-namespace)
              `x)
          `(((foil-namespace
              .
              ,(thunk
                (run (~s `(for ([sym (in-list (namespace-mapped-symbols))])
                            (namespace-undefine-variable! sym)))
                     empty-defs any?)))))
          any?)
     (run-result "" #f '(x-value)))

    (check-equal?
     (let ()
       (define noop (~s `(void)))
       (define noop-defs `(((args . "no-args"))))
       (define foo (~s `(module foo racket
                          (displayln args)
                          (run ,noop)
                          (displayln args))))
       (define foo-defs `(((run . ,(run-fn noop-defs))
                           (args . "args"))))
       (define app (~s `(run ,foo)))
       (define app-defs `(((run . ,(run-fn foo-defs)))))
       (run app app-defs any?))
     (run-result "args\nargs\n" #f '()))

    (check-equal?
     (let ()
       (define noop (~s `(void)))
       (define noop-defs `(((args . "no-args"))))
       (define foo (~s `(displayln args)
                       `(run ,noop)
                       `(displayln args)))
       (define foo-defs `(((run . ,(run-fn noop-defs))
                           (args . "args"))))
       (define app (~s `(run ,foo)))
       (define app-defs `(((run . ,(run-fn foo-defs)))))
       (run app app-defs any?))
     (run-result "args\nargs\n" #f '()))

    (check-equal?
     (let ()
       (define selfrec-module
         (~s `(module selfrec racket
                (define x value)
                (displayln x)
                (recur)
                (displayln x))))
       (define selfrec-defs
         (for/fold ([defs `(((recur . ,void)
                             (value . top)))])
                   ([i (in-range 5)])
           `(((recur . ,(thunk ((run-fn defs) selfrec-module)))
              (value . ,i)))))
       (run selfrec-module selfrec-defs any?))
     (run-result (~a 4 3 2 1 0 'top
                     'top 0 1 2 3 4 ""
                     #:separator "\n") #f '())))

  (test-case "Exn Test"
    (check-not-false
     (run-result-stderr
      (run (~s `(raise "err"))
           empty-defs any?)))
    (check-not-false
     (run-result-stderr
      (run (~s `(run (~s `(raise "err"))))
           `(((run . ,(run-fn empty-defs))))
           any?)))))