suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: 5585e0e769f1bc5aab6a7c5abe95695bc551a7e3
This commit is contained in:
Robby Findler 2001-04-14 16:32:04 +00:00
parent 789900eaef
commit 9006b972fa
1 changed files with 137 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
collects/mred/mred.ss
View File

@ -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)