242 lines
8.5 KiB
Racket
242 lines
8.5 KiB
Racket
(module repl racket/base
|
|
(require racket/class
|
|
(prefix-in wx: "kernel.rkt")
|
|
(prefix-in wx: racket/snip/private/style)
|
|
"editor.rkt"
|
|
"app.rkt"
|
|
"mrtop.rkt"
|
|
"mrcanvas.rkt"
|
|
"mrmenu.rkt"
|
|
"filedialog.rkt")
|
|
|
|
(provide graphical-read-eval-print-loop
|
|
textual-read-eval-print-loop)
|
|
|
|
(define (-graphical-read-eval-print-loop user-esp override-ports?)
|
|
;; The REPL buffer class
|
|
(define esq:text%
|
|
(class text%
|
|
(inherit insert last-position get-text erase change-style clear-undos set-max-undo-history)
|
|
(rename-super [super-on-char on-char])
|
|
(define prompt-pos 0)
|
|
(define locked? #f)
|
|
(augment*
|
|
[can-insert? (lambda (start end) (and (>= start prompt-pos) (not locked?)))]
|
|
[can-delete? (lambda (start end) (and (>= start prompt-pos) (not locked?)))])
|
|
(override*
|
|
[on-char (lambda (c)
|
|
(super-on-char c)
|
|
(when (and (memq (send c get-key-code) '(#\return #\newline numpad-enter))
|
|
(not locked?))
|
|
(set! locked? #t)
|
|
(evaluate (get-text prompt-pos (last-position)))))])
|
|
(public*
|
|
[new-prompt (lambda ()
|
|
(output "> ")
|
|
(set! prompt-pos (last-position))
|
|
(set! locked? #f)
|
|
(clear-undos))]
|
|
[output (lambda (str)
|
|
(let ([l? locked?])
|
|
(set! locked? #f)
|
|
(insert str)
|
|
(set! locked? l?)))]
|
|
[reset (lambda ()
|
|
(set! locked? #f)
|
|
(set! prompt-pos 0)
|
|
(erase)
|
|
(new-prompt))])
|
|
(super-new)
|
|
(let ([s (last-position)]
|
|
[m (regexp-match #rx"^(.*), (Copyright.*)$" (banner))])
|
|
(insert (if m
|
|
(format "~a." (cadr m))
|
|
(let ([b (banner)])
|
|
(substring b 0 (sub1 (string-length b))))))
|
|
(let ([e (last-position)])
|
|
(insert #\newline)
|
|
(change-style (send (make-object wx:style-delta% 'change-bold) set-delta-foreground "BLUE") s e))
|
|
(when m
|
|
(output (caddr m))))
|
|
(insert "This is a simple window for evaluating Racket expressions.") (insert #\newline)
|
|
(let ([s (last-position)])
|
|
(insert "Quit now and run DrRacket to get a better window.")
|
|
(let ([e (last-position)])
|
|
(insert #\newline)
|
|
(change-style
|
|
(send (make-object wx:style-delta% 'change-italic) set-delta-foreground "RED")
|
|
s e)))
|
|
(insert "The current input port always returns eof.") (insert #\newline)
|
|
(new-prompt)
|
|
(set-max-undo-history 'forever)))
|
|
|
|
;; GUI creation
|
|
(define frame (make-object (class frame%
|
|
(init-rest args)
|
|
(inherit accept-drop-files)
|
|
(augment*
|
|
[on-close (lambda ()
|
|
(custodian-shutdown-all user-custodian)
|
|
(semaphore-post waiting))])
|
|
(override*
|
|
[on-drop-file (lambda (f) (evaluate (format "(load ~s)" (path->string f))))])
|
|
(apply super-make-object args) (accept-drop-files #t))
|
|
"GRacket REPL" #f 500 400))
|
|
(define repl-buffer (make-object esq:text%))
|
|
(define repl-display-canvas (new editor-canvas% [parent frame] [style '(no-border auto-hscroll resize-corner)]))
|
|
|
|
(define esq-eventspace (wx:current-eventspace))
|
|
(define (queue-output proc)
|
|
(parameterize ((wx:current-eventspace esq-eventspace))
|
|
(wx:queue-callback proc #f)))
|
|
|
|
;; User space initialization
|
|
(define user-custodian (make-custodian))
|
|
|
|
(define user-output-port
|
|
(let ([leftover #""]
|
|
[cvt (bytes-open-converter "UTF-8-permissive" "UTF-8")])
|
|
(make-output-port
|
|
'console
|
|
always-evt
|
|
(lambda (s start end flush? breakable?)
|
|
(queue-output (lambda ()
|
|
;; s might end in the middle of a UTF-8 encoding.
|
|
;; Get a complete prefix, and save the rest.
|
|
(let ([s (bytes-append leftover (subbytes s start end))])
|
|
(let-values ([(res used status) (bytes-convert cvt s)])
|
|
(send repl-buffer output (bytes->string/utf-8 res))
|
|
(set! leftover (subbytes s used))))))
|
|
(- end start))
|
|
void))) ; no close action
|
|
|
|
(define user-eventspace
|
|
(or user-esp
|
|
(parameterize ((current-custodian user-custodian))
|
|
(wx:make-eventspace))))
|
|
|
|
;; Evaluation
|
|
|
|
(define (evaluate expr-str)
|
|
(parameterize ((wx:current-eventspace user-eventspace))
|
|
(wx:queue-callback
|
|
(lambda ()
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda () (call-with-continuation-prompt
|
|
(lambda () (eval (cons
|
|
'#%top-interaction
|
|
(read (open-input-string expr-str)))))))
|
|
(lambda results
|
|
(for-each
|
|
(lambda (v)
|
|
(parameterize ([current-output-port user-output-port])
|
|
(print v)
|
|
(newline)))
|
|
results))))
|
|
(lambda ()
|
|
(queue-output (lambda () (send repl-buffer new-prompt)))))))))
|
|
|
|
(define waiting (make-semaphore 0))
|
|
|
|
(let ([mb (make-object menu-bar% frame)])
|
|
(let ([m (make-object menu% "&File" mb)])
|
|
(make-object menu-item% "Load File..." m (lambda (i e) (let ([f (get-file #f frame)])
|
|
(and f
|
|
(evaluate (format "(load ~s)" (path->string f)))))))
|
|
(unless (current-eventspace-has-standard-menus?)
|
|
(make-object menu-item%
|
|
(if (eq? (system-type) 'windows)
|
|
"E&xit"
|
|
"&Quit")
|
|
m (lambda (i e) (send frame on-close) (send frame show #f)) #\q)))
|
|
(let ([m (make-object menu% "&Edit" mb)])
|
|
(append-editor-operation-menu-items m #f)))
|
|
|
|
;; Just a few extra key bindings:
|
|
((current-text-keymap-initializer) (send repl-buffer get-keymap))
|
|
(send repl-buffer auto-wrap #t)
|
|
|
|
;; Go
|
|
(when override-ports?
|
|
(parameterize ((wx:current-eventspace user-eventspace))
|
|
(wx:queue-callback
|
|
(lambda ()
|
|
(current-output-port user-output-port)
|
|
(current-error-port user-output-port)
|
|
(current-input-port (open-input-bytes #"")))
|
|
#t)))
|
|
|
|
(send repl-display-canvas set-editor repl-buffer)
|
|
|
|
(send frame show #t)
|
|
|
|
(send repl-display-canvas focus)
|
|
|
|
(wx:yield waiting))
|
|
|
|
(define graphical-read-eval-print-loop
|
|
(case-lambda
|
|
[() (-graphical-read-eval-print-loop #f #t)]
|
|
[(esp)
|
|
(graphical-read-eval-print-loop esp (not esp))]
|
|
[(esp override-ports?)
|
|
(unless (or (not esp) (wx:eventspace? esp))
|
|
(raise-argument-error 'graphical-read-eval-print-loop "(or/c eventspace? #f)" esp))
|
|
(-graphical-read-eval-print-loop esp override-ports?)]))
|
|
|
|
(define (textual-read-eval-print-loop)
|
|
(define user-custodian (make-custodian))
|
|
(define user-eventspace
|
|
(parameterize ((current-custodian user-custodian))
|
|
(wx:make-eventspace)))
|
|
(define ready-sema (make-semaphore))
|
|
(define (evaluate expr)
|
|
(parameterize ((wx:current-eventspace user-eventspace))
|
|
(wx:queue-callback
|
|
(lambda ()
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda () (call-with-continuation-prompt
|
|
(lambda () (eval (cons
|
|
'#%top-interaction
|
|
expr)))))
|
|
(lambda results
|
|
(for-each
|
|
(lambda (v)
|
|
((current-print) v))
|
|
results))))
|
|
(lambda ()
|
|
(semaphore-post ready-sema)))))))
|
|
(parameterize-break
|
|
#f
|
|
(let loop ()
|
|
(let ([e (let read-loop ()
|
|
(call-with-continuation-prompt
|
|
;; Enable break during reading:
|
|
(lambda ()
|
|
(parameterize-break
|
|
#t
|
|
((current-prompt-read))))
|
|
(default-continuation-prompt-tag)
|
|
(lambda args (read-loop))))])
|
|
(unless (eof-object? e)
|
|
(evaluate e)
|
|
;; While waiting, redirect breaks:
|
|
(call-with-exception-handler
|
|
(lambda (exn)
|
|
(if (exn:break? exn)
|
|
(begin
|
|
(break-thread (eventspace-handler-thread user-eventspace))
|
|
((exn:break-continuation exn) (void)))
|
|
exn))
|
|
(lambda ()
|
|
(parameterize-break
|
|
#t
|
|
(semaphore-wait ready-sema))))
|
|
(loop)))))))
|