From 9006b972fa370a65afd65e33abe70bbfee27f1cc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 14 Apr 2001 16:32:04 +0000 Subject: [PATCH] ... original commit: 5585e0e769f1bc5aab6a7c5abe95695bc551a7e3 --- collects/mred/mred.ss | 175 +++++++++++++++++++++++++++++++++--------- 1 file changed, 137 insertions(+), 38 deletions(-) diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 7f6f6e3f..5ba8dfdc 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -4517,21 +4517,30 @@ (check-installer 'default-text-keymap-initializer))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; REPL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +(define bold-blue-style-delta + (send (make-object wx:style-delta% 'change-bold) set-delta-foreground "BLUE")) +(define italic-red-style-delta + (send (make-object wx:style-delta% 'change-italic) set-delta-foreground "RED")) +(define grey-style-delta + (send (make-object wx:style-delta%) set-delta-foreground "GRAY")) (define (-graphical-read-eval-print-loop user-esp) ;; The REPL buffer class (define esq:text% (class100 text% () - (inherit insert last-position get-text erase change-style clear-undos) + (inherit insert last-position get-text erase change-style clear-undos + begin-edit-sequence end-edit-sequence lock is-locked?) (rename [super-on-char on-char]) - (private-field [prompt-pos 0] [locked? #f]) + (private-field + [prompt-pos 0] + [locked? #f]) (override [can-insert? (lambda (start end) (and (>= start prompt-pos) (not locked?)))] [can-delete? (lambda (start end) (and (>= start prompt-pos) (not locked?)))] [on-char (lambda (c) (super-on-char c) (when (and (memq (send c get-key-code) '(#\return #\newline #\003)) - (not locked?)) + (not locked?) + (not (is-locked?))) (set! locked? #t) (evaluate (get-text prompt-pos (last-position)))))]) (public @@ -4545,30 +4554,40 @@ (set! locked? #f) (insert str) (set! locked? l?)))] + [kill-repl + (lambda () + (set! locked? #f) + (lock #f) + (change-style grey-style-delta 0 (last-position)) + (lock #t))] [reset (lambda () (set! locked? #f) + (lock #f) + (begin-edit-sequence) (set! prompt-pos 0) (erase) - (new-prompt))]) + (let ([s (last-position)] + [m (regexp-match "^(.*), (Copyright.*)$" (banner))]) + (insert (format "Welcome to ~a." (cadr m))) + (let ([e (last-position)]) + (insert #\newline) + (change-style bold-blue-style-delta s e)) + (output (caddr m))) + (insert "This is a simple window for evaluating MrEd Scheme expressions.") + (insert #\newline) + (let ([s (last-position)]) + (insert "Quit now and run DrScheme to get a better window.") + (let ([e (last-position)]) + (insert #\newline) + (change-style italic-red-style-delta s e))) + (insert "The current input port always returns eof.") + (insert #\newline) + (new-prompt) + (end-edit-sequence) + (clear-undos))]) (sequence (super-init) - (let ([s (last-position)] - [m (regexp-match "^(.*), (Copyright.*)$" (banner))]) - (insert (format "Welcome to ~a." (cadr m))) - (let ([e (last-position)]) - (insert #\newline) - (change-style (send (make-object wx:style-delta% 'change-bold) set-delta-foreground "BLUE") s e)) - (output (caddr m))) - (insert "This is a simple window for evaluating MrEd Scheme expressions.") (insert #\newline) - (let ([s (last-position)]) - (insert "Quit now and run DrScheme 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)))) + (reset)))) ;; GUI creation (define frame (make-object (class100 frame% args @@ -4582,6 +4601,23 @@ (apply super-init args) (accept-drop-files #t))) "MrEd REPL" #f 500 400)) (define repl-buffer (make-object esq:text%)) + + (define execute-panel (make-object horizontal-panel% frame)) + (define execute-button + (and (not user-esp) + (make-object button% "Execute File..." execute-panel + (lambda (x y) (do-execute))))) + (define reset-button + (and (not user-esp) + (make-object button% "Reset" execute-panel + (lambda (x y) + (do-reset))))) + (define kill-button + (and (not user-esp) + (make-object button% "Kill" execute-panel + (lambda (x y) + (do-kill))))) + (define repl-display-canvas (make-object editor-canvas% frame)) (define esq-eventspace (wx:current-eventspace)) @@ -4590,18 +4626,38 @@ (wx:queue-callback proc #f))) ;; User space initialization - (define user-custodian (make-custodian)) - + (define user-custodian 'user-custodian-not-yet-set) + (define user-namespace 'user-namespace-not-yet-set) (define user-output-port (make-output-port (lambda (s) (queue-output (lambda () (send repl-buffer output s)))) (lambda () 'nothing-to-close))) - (define user-eventspace - (or user-esp - (parameterize ((current-custodian user-custodian)) - (wx:make-eventspace)))) + (define user-eventspace 'user-eventspace-not-yet-set) + (define (user-space-init) + (set! user-custodian (make-custodian)) + (set! user-eventspace + (or user-esp + (parameterize ((current-custodian user-custodian)) + (wx:make-eventspace)))) + + (set! user-namespace (make-namespace)) + (let ([mred-name ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)] + [orig-namespace (current-namespace)]) + (parameterize ([current-namespace user-namespace]) + (namespace-attach-module orig-namespace mred-name))) + + (unless user-esp + (parameterize ((wx:current-eventspace user-eventspace)) + (wx:queue-callback + (lambda () + (current-namespace user-namespace) + (current-output-port user-output-port) + (current-error-port user-output-port) + (current-input-port (make-input-port (lambda () eof) void void))) + #t)))) + ;; Evaluation (define (evaluate expr-str) @@ -4624,7 +4680,36 @@ (queue-output (lambda () (send repl-buffer new-prompt))))))))) (define waiting (make-semaphore 0)) - + + (define execute-menu-item 'execute-menu-item-not-yet-set) + (define execute-filename #f) + (define (update-execute-label) + (when execute-button + (let ([label (if execute-filename + (format "Execute ~a" execute-filename) + "Execute File...")]) + (send execute-button set-label label) + (send execute-menu-item set-label label)))) + (define (do-execute) + (unless execute-filename + (set! execute-filename (get-file)) + (when execute-filename + (update-execute-label))) + (when execute-filename + (do-reset) + (evaluate (format "(load ~s)" execute-filename)))) + (define (do-reset) + (custodian-shutdown-all user-custodian) + (user-space-init) + (send repl-buffer reset)) + (define (do-kill) + (custodian-shutdown-all user-custodian) + (send repl-buffer kill-repl)) + + (send execute-panel stretchable-height #f) + (when execute-button + (send execute-button stretchable-width #t)) + (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)" f)))))) @@ -4634,21 +4719,35 @@ "&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))) + (append-editor-operation-menu-items m #f)) + (unless user-esp + (let ([m (make-object menu% "&Scheme" mb)]) + (set! execute-menu-item + (make-object menu-item% "Execute" m + (lambda (i e) + (do-execute)) + #\t)) + (make-object menu-item% "Reset" m + (lambda (i e) + (do-reset)) + #\r) + (make-object menu-item% "Kill" m + (lambda (i e) + (do-kill)) + #\k) + (make-object menu-item% "Reset Execute Button" m + (lambda (i e) + (set! execute-filename #f) + (update-execute-label)))))) + + (update-execute-label) ;; Just a few extra key bindings: ((current-text-keymap-initializer) (send repl-buffer get-keymap)) (send repl-buffer auto-wrap #t) ;; Go - (unless user-esp - (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 (make-input-port (lambda () eof) void void))) - #t))) + (user-space-init) (send repl-display-canvas set-editor repl-buffer)