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

...

Browse Source 
original commit: a2affedce7595ecfae47105cfb20fb9fcabaded9
This commit is contained in:
Robby Findler 1998-09-14 18:34:44 +00:00
parent 30396db566
commit bfa157d033
9 changed files with 229 additions and 362 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/canvas.ss
View File

@ -1,4 +1,4 @@
(unit/sig mred:canvas^ (unit/sig framework:canvas^
(import mred^ (import mred^
[preferences : framework:preferences^]) [preferences : framework:preferences^])

28
collects/framework/finder.ss
View File

@ -2,7 +2,7 @@
;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler ;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler
(unit/sig mred:finder^ (unit/sig framework:finder^
(import mred^ (import mred^
[preferences : framework:preferences^] [preferences : framework:preferences^]
[gui-utils : framework:gui-utils^] [gui-utils : framework:gui-utils^]
@ -158,17 +158,9 @@
(if (< which (length dirs)) (if (< which (length dirs))
(set-directory (list-ref dirs which)))))] (set-directory (list-ref dirs which)))))]
[do-name
(lambda (text event)
(if (eq? (send event get-event-type)
wx:const-event-type-text-enter-command)
(do-ok)))]
[do-name-list [do-name-list
(lambda (_ event) (lambda (list-box _)
(if (and (eq? (send event get-event-type) (when (send list-box get-string-selections)
wx:const-event-type-listbox-command)
(send event is-selection?))
(set-edit)))] (set-edit)))]
[do-result-list [do-result-list
@ -251,25 +243,25 @@
(if (or (not save-mode?) (if (or (not save-mode?)
(not (file-exists? file)) (not (file-exists? file))
replace-ok? replace-ok?
(= (wx:message-box (eq? (message-box "Warning"
(string-append (string-append
"The file " "The file "
file file
" already exists. " " already exists. "
"Replace it?") "Replace it?")
"Warning" #f
wx:const-yes-no) 'yes-no)
wx:const-yes)) 'yes))
(let ([normal-path (let ([normal-path
(with-handlers (with-handlers
([(lambda (_) #t) ([(lambda (_) #t)
(lambda (_) (lambda (_)
(wx:message-box (message-box
"Warning"
(string-append (string-append
"The file " "The file "
file file
" contains nonexistent directory or cycle.") " contains nonexistent directory or cycle."))
"Warning")
#f)]) #f)])
(mzlib:file:normalize-path file))]) (mzlib:file:normalize-path file))])
(when normal-path (when normal-path

2
collects/framework/group.ss
View File

@ -1,4 +1,4 @@
(unit/sig mred:group^ (unit/sig framework:group^
(import mred^ (import mred^
[exit : framework:exit^] [exit : framework:exit^]
[mzlib:function : mzlib:function^] [mzlib:function : mzlib:function^]

91
collects/framework/guiutils.ss
View File

@ -32,7 +32,7 @@
(semaphore-post semaphore))))) (semaphore-post semaphore)))))
(define local-busy-cursor (define local-busy-cursor
(let ([watch (make-object wx:cursor% wx:const-cursor-watch)]) (let ([watch (make-object cursor% 'watch)])
(opt-lambda (win thunk [delay (cursor-delay)]) (opt-lambda (win thunk [delay (cursor-delay)])
(let* ([old-cursor #f] (let* ([old-cursor #f]
[cursor-off void]) [cursor-off void])
@ -44,11 +44,11 @@
(lambda () (lambda ()
(if win (if win
(set! old-cursor (send win set-cursor watch)) (set! old-cursor (send win set-cursor watch))
(wx:begin-busy-cursor))) (begin-busy-cursor)))
(lambda () (lambda ()
(if win (if win
(send win set-cursor old-cursor) (send win set-cursor old-cursor)
(wx:end-busy-cursor)))))) (end-busy-cursor))))))
(lambda () (thunk)) (lambda () (thunk))
(lambda () (cursor-off))))))) (lambda () (cursor-off)))))))
@ -57,7 +57,7 @@
(let* ([result (void)] (let* ([result (void)]
[dialog% [dialog%
(class dialog-box% () (class dialog-box% ()
(inherit show new-line fit tab center set-size) (inherit show center)
(private (private
[on-dont-save [on-dont-save
(lambda args (lambda args
@ -97,45 +97,21 @@
(if (not can-save-now?) (if (not can-save-now?)
(begin (send cancel set-focus) (begin (send cancel set-focus)
(send now show #f)) (send now show #f))
(send now set-focus))) (send now set-focus))))
(send msg center wx:const-horizontal))
(set-size -1 -1 10 10) (center 'both)
(center wx:const-both)
(show #t)))]) (show #t)))])
(make-object dialog%) (make-object dialog%)
result))) result)))
(define read-snips/chars-from-buffer
(opt-lambda (edit [start 0] [end (send edit last-position)])
(let ([pos start]
[box (box 0)])
(lambda ()
(let* ([snip (send edit find-snip pos
wx:const-snip-after-or-null box)]
[ans
(cond
[(<= end pos) eof]
[(null? snip) eof]
[(is-a? snip wx:text-snip%)
(let ([t (send snip get-text (- pos (unbox box)) 1)])
(unless (= (string-length t) 1)
(error 'read-snips/chars-from-buffer
"unexpected string, t: ~s; pos: ~a box: ~a"
t pos box))
(string-ref t 0))]
[else snip])])
(set! pos (add1 pos))
ans)))))
(define get-choice (define get-choice
(opt-lambda (message true-choice false-choice (opt-lambda (message true-choice false-choice
[title "Warning"][x -1][y -1]) [title "Warning"][x -1][y -1])
(let* ([result (void)] (let* ([result (void)]
[dialog% [dialog%
(class wx:dialog-box% () (class dialog-box% ()
(inherit show new-line fit tab center) (inherit show center)
(private (private
[on-true [on-true
(lambda args (lambda args
@ -158,28 +134,39 @@
[msgs (map [msgs (map
(lambda (message) (lambda (message)
(begin0 (begin0
(make-object wx:message% this message) (make-object message% this message)))
(new-line)))
messages)]) messages)])
(send (make-object wx:button% this (send (make-object button% true-choice this on-true) focus)
on-true true-choice) (make-object button% false-choice this on-false)
set-focus)
(tab 50)
(make-object wx:button% this on-false false-choice)
(fit)
(if (and (< x 0) (< y 0)) (center 'both)
(map (lambda (msg)
(send msg center wx:const-horizontal))
msgs)))
(center wx:const-both) (show #t))))])
(show #t)))])
(make-object dialog%) (make-object dialog%)
result))) result)))
(define read-snips/chars-from-buffer
(opt-lambda (edit [start 0] [end (send edit last-position)])
(let ([pos start]
[box (box 0)])
(lambda ()
(let* ([snip (send edit find-snip pos 'after-or-none box)]
[ans
(cond
[(<= end pos) eof]
[(not snip) eof]
[(is-a? snip text-snip%)
(let ([t (send snip get-text (- pos (unbox box)) 1)])
(unless (= (string-length t) 1)
(error 'read-snips/chars-from-buffer
"unexpected string, t: ~s; pos: ~a box: ~a"
t pos box))
(string-ref t 0))]
[else snip])])
(set! pos (add1 pos))
ans)))))
(define open-input-buffer (define open-input-buffer
(lambda (buffer) (lambda (buffer)
(let ([pos 0]) (let ([pos 0])
@ -194,12 +181,4 @@
(lambda () (lambda ()
#t) #t)
(lambda () (lambda ()
(void)))))) (void)))))))
; For use with wx:set-print-paper-name
(define print-paper-names
(list
"A4 210 x 297 mm"
"A3 297 x 420 mm"
"Letter 8 1/2 x 11 in"
"Legal 8 1/2 x 14 in")))

65
collects/framework/main.ss
View File

@ -4,18 +4,14 @@
;; preferences ;; preferences
(mred:preferences:set-preference-default 'mred:verify-change-format #f boolean?) (preferences:set-default 'framework:verify-change-format #f boolean?)
(mred:preferences:set-preference-default 'mred:auto-set-wrap? #f boolean?) (preferences:set-default 'framework:auto-set-wrap? #f boolean?)
(preferences:set-default 'framework:display-line-numbers #t boolean?) (preferences:set-default 'framework:display-line-numbers #t boolean?)
(preferences:set-preference-default 'mred:show-status-line (preferences:set-default 'framework:show-status-line #t boolean?)
#t (preferences:set-default 'framework:line-offsets t boolean?)
boolean?)
(preferences:set-preference-default 'mred:line-offsets
#t
boolean?)
@ -44,7 +40,7 @@
share share-from share share-from
sequence)) sequence))
(for-each (lambda (x) (hash-table-put! hash-table x 'lambda)) (for-each (lambda (x) (hash-table-put! hash-table x 'lambda))
'(lambda let let* letrec letrec* recur '(lambda let let* letrec recur
let/cc let/ec letcc catch let/cc let/ec letcc catch
let-syntax letrec-syntax syntax-case let-syntax letrec-syntax syntax-case
let-signature fluid-let let-signature fluid-let
@ -61,13 +57,13 @@
call-with-input-file with-input-from-file call-with-input-file with-input-from-file
with-input-from-port call-with-output-file with-input-from-port call-with-output-file
with-output-to-file with-output-to-port)) with-output-to-file with-output-to-port))
(mred:preferences:set-preference-un/marshall (preferences:set-un/marshall
'mred:tabify 'framework:tabify
(lambda (t) (hash-table-map t list)) (lambda (t) (hash-table-map t list))
(lambda (l) (let ([h (make-hash-table)]) (lambda (l) (let ([h (make-hash-table)])
(for-each (lambda (x) (apply hash-table-put! h x)) l) (for-each (lambda (x) (apply hash-table-put! h x)) l)
h))) h)))
(mred:preferences:set-preference-default 'mred:tabify hash-table hash-table?)) (preferences:set-default 'framework:tabify hash-table hash-table?))
(preferences:set-default 'framework:autosave-delay 300 number?) (preferences:set-default 'framework:autosave-delay 300 number?)
@ -78,7 +74,7 @@
boolean?) boolean?)
(preferences:set 'framework:show-periods-in-dirlist #f boolean?) (preferences:set 'framework:show-periods-in-dirlist #f boolean?)
(preferences:set 'framework:file-dialogs (preferences:set 'framework:file-dialogs
(if (eq? wx:platform 'unix) (if (eq? (system-type) 'unix)
'common 'common
'std) 'std)
(lambda (x) (lambda (x)
@ -91,7 +87,7 @@
(let*-values (let*-values
([(get-keywords) ([(get-keywords)
(lambda (hash-table) (lambda (hash-table)
(letrec* ([all-keywords (hash-table-map hash-table list)] (letrec ([all-keywords (hash-table-map hash-table list)]
[pick-out (lambda (wanted in out) [pick-out (lambda (wanted in out)
(cond (cond
[(null? in) (mzlib:function:quicksort out string<=?)] [(null? in) (mzlib:function:quicksort out string<=?)]
@ -102,11 +98,11 @@
(pick-out 'define all-keywords null) (pick-out 'define all-keywords null)
(pick-out 'lambda all-keywords null))))] (pick-out 'lambda all-keywords null))))]
[(begin-keywords define-keywords lambda-keywords) [(begin-keywords define-keywords lambda-keywords)
(get-keywords (mred:preferences:get-preference 'mred:tabify))]) (get-keywords (preferences:get 'framework:tabify))])
(let* ([add-callback (let* ([add-callback
(lambda (keyword-type keyword-symbol list-box) (lambda (keyword-type keyword-symbol list-box)
(lambda (button command) (lambda (button command)
(let ([new-one (mred:gui-utils:get-text-from-user (let ([new-one (get-text-from-user
(string-append "Enter new " keyword-type "-like keyword:") (string-append "Enter new " keyword-type "-like keyword:")
(string-append keyword-type " Keyword"))]) (string-append keyword-type " Keyword"))])
(when new-one (when new-one
@ -114,33 +110,33 @@
(read (open-input-string new-one)))]) (read (open-input-string new-one)))])
(cond (cond
[(and (symbol? parsed) [(and (symbol? parsed)
(hash-table-get (mred:preferences:get-preference 'mred:tabify) (hash-table-get (preferences:get 'framework:tabify)
parsed parsed
(lambda () #f))) (lambda () #f)))
(wx:message-box (format "\"~a\" is already a specially indented keyword" parsed) (message-box "Error"
"Error")] (format "\"~a\" is already a specially indented keyword" parsed))]
[(symbol? parsed) [(symbol? parsed)
(hash-table-put! (mred:preferences:get-preference 'mred:tabify) (hash-table-put! (preferences:get 'framework:tabify)
parsed keyword-symbol) parsed keyword-symbol)
(send list-box append (symbol->string parsed))] (send list-box append (symbol->string parsed))]
[else (wx:message-box (format "expected a symbol, found: ~a" new-one) "Error")]))))))] [else (message-box "Error" (format "expected a symbol, found: ~a" new-one))]))))))]
[delete-callback [delete-callback
(lambda (list-box) (lambda (list-box)
(lambda (button command) (lambda (button command)
(let* ([selections (send list-box get-selections)] (let* ([selections (send list-box get-selections)]
[symbols (map (lambda (x) (string->symbol (send list-box get-string x))) selections)]) [symbols (map (lambda (x) (string->symbol (send list-box get-string x))) selections)])
(for-each (lambda (x) (send list-box delete x)) (reverse selections)) (for-each (lambda (x) (send list-box delete x)) (reverse selections))
(let ([ht (mred:preferences:get-preference 'mred:tabify)]) (let ([ht (preferences:get 'framework:tabify)])
(for-each (lambda (x) (hash-table-remove! ht x)) symbols)))))] (for-each (lambda (x) (hash-table-remove! ht x)) symbols)))))]
[main-panel (make-object mred:horizontal-panel% p)] [main-panel (make-object horizontal-panel% p)]
[make-column [make-column
(lambda (string symbol keywords) (lambda (string symbol keywords)
(let* ([vert (make-object mred:vertical-panel% main-panel)] (let* ([vert (make-object vertical-panel% main-panel)]
[_ (make-object mred:message% vert (string-append string "-like Keywords"))] [_ (make-object message% (string-append string "-like Keywords") vert)]
[box (make-object mred:list-box% vert null "" wx:const-multiple -1 -1 -1 -1 keywords)] [box (make-object list-box% #f keywords vert #f 'multiple void)]
[button-panel (make-object mred:horizontal-panel% vert)] [button-panel (make-object horizontal-panel% vert)]
[add-button (make-object mred:button% button-panel (add-callback string symbol box) "Add")] [add-button (make-object button% "Add" (add-callback string symbol box) button-panel)]
[delete-button (make-object mred:button% button-panel (delete-callback box) "Remove")]) [delete-button (make-object button% "Remove" (delete-callback box) button-panel)])
(send* button-panel (send* button-panel
(major-align-center) (major-align-center)
(stretchable-in-y #f)) (stretchable-in-y #f))
@ -159,7 +155,7 @@
(reset define-list-box define-keywords) (reset define-list-box define-keywords)
(reset lambda-list-box lambda-keywords) (reset lambda-list-box lambda-keywords)
#t))]) #t))])
(mred:preferences:add-preference-callback 'mred:tabify (lambda (p v) (update-list-boxes v))) (preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
main-panel)))) main-panel))))
(preferences:read) (preferences:read)
@ -208,10 +204,11 @@
(lambda () (lambda ()
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (exn) (lambda (exn)
(mred:gui-utils:message-box (message-box
"Saving Prefs"
(format "Error saving preferences: ~a" (format "Error saving preferences: ~a"
(exn-message exn)) (exn-message exn))))])
"Saving Prefs"))])
(save-user-preferences)))) (save-user-preferences))))
(wx:application-file-handler edit-file)) ;(wx:application-file-handler edit-file)
)

64
collects/framework/prefs.ss
View File

@ -138,13 +138,13 @@
(lambda () (lambda ()
(hash-table-for-each (hash-table-for-each
defaults defaults
(lambda (p v) (set-preference p v))))) (lambda (p v) (set p v)))))
(define set-default (define set-default
(lambda (p value checker) (lambda (p value checker)
(let ([t (checker value)]) (let ([t (checker value)])
(unless t (unless t
(error 'set-preference-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker t value))) (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker t value)))
(hash-table-get preferences p (hash-table-get preferences p
(lambda () (lambda ()
(hash-table-put! preferences p (make-pref value)))) (hash-table-put! preferences p (make-pref value))))
@ -195,17 +195,17 @@
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
(cond (cond
[(and (pref? ht-pref) unmarshall-struct) [(and (pref? ht-pref) unmarshall-struct)
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))] (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
;; in this case, assume that no marshalling/unmarshalling ;; in this case, assume that no marshalling/unmarshalling
;; is going to take place with the pref, since an unmarshalled ;; is going to take place with the pref, since an unmarshalled
;; pref was already there. ;; pref was already there.
[(pref? ht-pref) [(pref? ht-pref)
(set-preference p marshalled)] (set p marshalled)]
[(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)] [(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)]
[(and (not ht-pref) unmarshall-struct) [(and (not ht-pref) unmarshall-struct)
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))] (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
[(not ht-pref) [(not ht-pref)
(hash-table-put! preferences p (make-marshalled marshalled))] (hash-table-put! preferences p (make-marshalled marshalled))]
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))]) [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))])
@ -284,13 +284,13 @@
(lambda (family) (lambda (family)
(let ([name (build-font-preference-symbol family)] (let ([name (build-font-preference-symbol family)]
[font-entry (build-font-entry family)]) [font-entry (build-font-entry family)])
(set-preference-default name (set-default name
default default
(cond (cond
[(string? default) string?] [(string? default) string?]
[(number? default) number?] [(number? default) number?]
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)])) [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
(add-preference-callback (add-callback
name name
(lambda (p new-value) (lambda (p new-value)
(write-resource (write-resource
@ -335,12 +335,12 @@
(lambda (pref title bool->pref pref->bool) (lambda (pref title bool->pref pref->bool)
(let* ([callback (let* ([callback
(lambda (_ command) (lambda (_ command)
(set-preference pref (bool->pref (send command checked?))))] (set pref (bool->pref (send command checked?))))]
[pref-value (get-preference pref)] [pref-value (get pref)]
[initial-value (pref->bool pref-value)] [initial-value (pref->bool pref-value)]
[c (make-object check-box% main callback title)]) [c (make-object check-box% main callback title)])
(send c set-value initial-value) (send c set-value initial-value)
(add-preference-callback pref (add-callback pref
(lambda (p v) (lambda (p v)
(send c set-value (pref->bool v))))))] (send c set-value (pref->bool v))))))]
[id (lambda (x) x)]) [id (lambda (x) x)])
@ -374,10 +374,10 @@
(make-ppanel (make-ppanel
"Default Fonts" "Default Fonts"
(lambda (parent) (lambda (parent)
(letrec* ([font-size-pref-sym (build-font-preference-symbol font-size-entry)] (letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
[ex-string "The quick brown fox jumped over the lazy dogs."] [ex-string "The quick brown fox jumped over the lazy dogs."]
[main (make-object vertical-panel% parent)] [main (make-object vertical-panel% parent)]
[fonts (cons font-default-string (wx:get-font-list))] [fonts (cons font-default-string (get-face-list))]
[make-family-panel [make-family-panel
(lambda (name) (lambda (name)
(let* ([pref-sym (build-font-preference-symbol name)] (let* ([pref-sym (build-font-preference-symbol name)]
@ -388,11 +388,11 @@
[set-edit-font [set-edit-font
(lambda (size) (lambda (size)
(let ([delta (make-object style-delta% 'change-size size)] (let ([delta (make-object style-delta% 'change-size size)]
[face (get-preference pref-sym)]) [face (get pref-sym)])
(if (and (string=? face font-default-string) (if (and (string=? face font-default-string)
family-const-pair) family-const-pair)
(send delta set-family (cadr family-const-pair)) (send delta set-family (cadr family-const-pair))
(send delta set-delta-face (get-preference pref-sym))) (send delta set-delta-face (get pref-sym)))
(send edit change-style delta 0 (send edit last-position))))] (send edit change-style delta 0 (send edit last-position))))]
@ -414,24 +414,21 @@
button% horiz button% horiz
(lambda (button evt) (lambda (button evt)
(let ([new-value (let ([new-value
(mred:gui-utils:get-single-choice (get-choice-from-user
"Fonts"
(format "Please choose a new ~a font" (format "Please choose a new ~a font"
name) name)
"Fonts" fonts)])
fonts
null -1 -1 #t 300 400)])
(when new-value (when new-value
(set-preference pref-sym (set pref-sym new-value)
new-value) (set-edit-font (get font-size-pref-sym)))))
(set-edit-font (get-preference font-size-pref-sym)))))
"Change")] "Change")]
;; WARNING!!! CHECK INIT ARGS wx: [canvas (make-object editor-canvas% horiz
[canvas (make-object editor-canvas% horiz "" edit
(list 'hide-hscroll (list 'hide-hscroll
'hide-vscroll))]) 'hide-vscroll))])
(set-edit-font (get-preference font-size-pref-sym)) (set-edit-font (get font-size-pref-sym))
(send canvas set-media edit) (add-callback
(add-preference-callback
pref-sym pref-sym
(lambda (p new-value) (lambda (p new-value)
(send horiz change-children (send horiz change-children
@ -467,8 +464,7 @@
[size-slider [size-slider
(make-object slider% size-panel (make-object slider% size-panel
(lambda (slider evt) (lambda (slider evt)
(set-preference font-size-pref-sym (set font-size-pref-sym (send slider get-value)))
(send slider get-value)))
"Size" "Size"
(let ([b (box 0)]) (let ([b (box 0)])
(if (get-resource font-section (if (get-resource font-section
@ -480,7 +476,7 @@
[guard-change-font (later-on)]) [guard-change-font (later-on)])
(update-message-sizes font-message-get-widths font-message-user-min-sizes) (update-message-sizes font-message-get-widths font-message-user-min-sizes)
(update-message-sizes category-message-get-widths category-message-user-min-sizes) (update-message-sizes category-message-get-widths category-message-user-min-sizes)
(add-preference-callback (add-callback
font-size-pref-sym font-size-pref-sym
(lambda (p value) (lambda (p value)
(guard-change-font (guard-change-font
@ -533,7 +529,7 @@
(lambda () (lambda ()
(run-once (run-once
(lambda () (lambda ()
(save-user-preferences) (save)
(if preferences-dialog (if preferences-dialog
(send preferences-dialog show #t) (send preferences-dialog show #t)
(set! preferences-dialog (set! preferences-dialog
@ -588,12 +584,12 @@
single-panel single-panel
bottom-panel)))))] bottom-panel)))))]
[ok-callback (lambda args [ok-callback (lambda args
(save-user-preferences) (save)
(hide-preferences-dialog))] (hide-dialog))]
[ok-button (make-object button% bottom-panel ok-callback "OK")] [ok-button (make-object button% bottom-panel ok-callback "OK")]
[cancel-callback (lambda args [cancel-callback (lambda args
(hide-preferences-dialog) (hide-dialog)
(read-user-preferences))] (read))]
[cancel-button (make-object button% bottom-panel cancel-callback "Cancel")]) [cancel-button (make-object button% bottom-panel cancel-callback "Cancel")])
(send ok-button user-min-width (send cancel-button get-width)) (send ok-button user-min-width (send cancel-button get-width))
(send* bottom-panel (send* bottom-panel

2
collects/framework/scheme.ss
View File

@ -312,7 +312,7 @@
[balance-parens [balance-parens
(let-struct string/pos (string pos) (let-struct string/pos (string pos)
(lambda (key) (lambda (key)
(letrec* ([char (integer->char code)] (letrec ([char (integer->char code)]
[here (get-start-position)] [here (get-start-position)]
[limit (get-limit here)] [limit (get-limit here)]
[paren-match? (preferences:get 'framework:paren-match)] [paren-match? (preferences:get 'framework:paren-match)]

13
collects/framework/sig.ss
View File

@ -256,18 +256,7 @@
(define-signature framework:match-cache^ (define-signature framework:match-cache^
(%)) (%))
(define-signature mred:menu^
(max-manual-menu-id
generate-menu-id
make-menu%
menu%
make-menu-bar%
menu-bar%))
(define-signature mred:project^
(project-frame-group%
make-project-frame%
project-frame%))
(define-signature framework:scheme-paren^ (define-signature framework:scheme-paren^
(paren-pairs (paren-pairs
@ -294,7 +283,7 @@
backward-match backward-match
skip-whitespace)) skip-whitespace))
(define-signature mred^ (define-signature framework^
([unit application : framework:application^] ([unit application : framework:application^]
[unit version : framework:version^] [unit version : framework:version^]
[unit exn : framework:exn^] [unit exn : framework:exn^]

86
collects/mred/panel.ss
View File

@ -1,86 +0,0 @@
(unit/sig mred:panel^
(import [wx : wx^]
[mred:constants : mred:constants^]
[mred:container : mred:container^]
[mred:canvas : mred:canvas^]
mzlib:function^)
(mred:debug:printf 'invoke "mred:panel@")
(define make-edit-panel%
(lambda (super%)
(class-asi super%
(rename [super-change-children change-children])
(inherit get-parent change-children children)
(public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)])
(private
[split-edits null])
(public
[collapse
(lambda (canvas)
(let ([media (send canvas get-media)])
(if (memq media split-edits)
(letrec ([helper
(lambda (canvas/panel)
(if (eq? canvas/panel this)
(begin (cond
[(and (= (length children) 1)
(eq? canvas (car children)))
(void)]
[(member canvas children)
(change-children (lambda (l) (list canvas)))]
[else
(change-children
(lambda (l)
(let ([c (make-object (object-class canvas) this)])
(send c set-media media)
(list c))))])
(wx:bell))
(let* ([parent (send canvas/panel get-parent)]
[parents-children (ivar parent children)]
[num-children (length parents-children)])
(if (<= num-children 1)
(helper parent)
(begin (send parent delete-child canvas/panel)
(send (car (ivar parent children)) set-focus))))))])
(send media remove-canvas canvas)
(helper canvas))
(wx:bell))))]
[split
(opt-lambda (canvas [panel% mred:container:horizontal-panel%])
(let* ([frame (ivar canvas frame)]
[media (send canvas get-media)]
[canvas% (object-class canvas)]
[parent (send canvas get-parent)]
[new-panel #f]
[left-split #f]
[right-split #f]
[before #t])
(set! split-edits (cons media split-edits))
(dynamic-wind
(lambda ()
(set! before (send frame delay-updates))
(send frame delay-updates #t))
(lambda ()
(set! new-panel (make-object panel% parent))
(set! left-split (make-object canvas% new-panel))
(set! right-split (make-object canvas% new-panel))
(send parent change-children
(lambda (l)
(let ([before (remq new-panel l)])
(map (lambda (x) (if (eq? x canvas)
new-panel
x))
before)))))
(lambda () (send frame delay-updates before)))
(send* media (remove-canvas canvas)
(add-canvas left-split)
(add-canvas right-split))
(send* left-split (set-media media) (set-focus))
(send* right-split (set-media media))))]))))
(define horizontal-edit-panel%
(make-edit-panel% mred:container:horizontal-panel%))
(define vertical-edit-panel%
(make-edit-panel% mred:container:vertical-panel%)))