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

.

Browse Source 
original commit: 902dd16827af0c70c416a9ef1c7d8126cde345b0
This commit is contained in:
Matthew Flatt 2004-06-22 13:31:02 +00:00
parent 80a2206b3f
commit ff5a41e4ab
15 changed files with 158 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/framework/decorated-editor-snip.ss
View File

@ -33,7 +33,6 @@
[define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)] [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)]
(inherit get-admin) (inherit get-admin)
(rename [super-on-event on-event])
(define/override (on-event dc x y editorx editory evt) (define/override (on-event dc x y editorx editory evt)
(cond (cond
[(send evt get-right-down) [(send evt get-right-down)
@ -67,12 +66,11 @@
(let ([admin (get-admin)]) (let ([admin (get-admin)])
(when admin (when admin
(send admin popup-menu menu this (+ sx 1) (+ sy 1))))] (send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
[else (super-on-event dc x y editorx editory evt)])))] [else (super on-event dc x y editorx editory evt)])))]
[else [else
(super-on-event dc x y editorx editory evt)])) (super on-event dc x y editorx editory evt)]))
(inherit get-extent get-inset) (inherit get-extent get-inset)
(rename [super-draw draw])
(define/override (draw dc x y left top right bottom dx dy draw-caret) (define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([bm (get-corner-bitmap)] (let ([bm (get-corner-bitmap)]
[bil (box 0)] [bil (box 0)]
@ -88,7 +86,7 @@
(get-extent dc x y bw bh #f #f #f #f) (get-extent dc x y bw bh #f #f #f #f)
(get-inset bil bit bir bib) (get-inset bil bit bir bib)
(get-margin bml bmt bmr bmb) (get-margin bml bmt bmr bmb)
(super-draw dc x y left top right bottom dx dy draw-caret) (super draw dc x y left top right bottom dx dy draw-caret)
(let* ([old-pen (send dc get-pen)] (let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]) [old-brush (send dc get-brush)])

1
collects/framework/private/autosave.ss
View File

@ -168,7 +168,6 @@
(define final-frame% (define final-frame%
(class frame:basic% (class frame:basic%
(rename [super-on-close on-close])
(define/override (can-close?) #t) (define/override (can-close?) #t)
(define/override (on-close) (define/override (on-close)
(send (group:get-the-frame-group) (send (group:get-the-frame-group)

12
collects/framework/private/canvas.ss
View File

@ -22,11 +22,10 @@
(define delegate-mixin (define delegate-mixin
(mixin (basic<%>) (delegate<%>) (mixin (basic<%>) (delegate<%>)
(rename [super-on-superwindow-show on-superwindow-show])
(inherit get-top-level-window) (inherit get-top-level-window)
(define/override (on-superwindow-show shown?) (define/override (on-superwindow-show shown?)
(send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f) (send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f)
(super-on-superwindow-show shown?)) (super on-superwindow-show shown?))
(super-instantiate ()))) (super-instantiate ())))
(define info<%> (interface (basic<%>))) (define info<%> (interface (basic<%>)))
@ -34,18 +33,16 @@
(define info-mixin (define info-mixin
(mixin (basic<%>) (info<%>) (mixin (basic<%>) (info<%>)
(inherit has-focus? get-top-level-window) (inherit has-focus? get-top-level-window)
(rename [super-on-focus on-focus]
[super-set-editor set-editor])
(override on-focus set-editor) (override on-focus set-editor)
[define on-focus [define on-focus
(lambda (on?) (lambda (on?)
(super-on-focus on?) (super on-focus on?)
(send (get-top-level-window) set-info-canvas (and on? this)) (send (get-top-level-window) set-info-canvas (and on? this))
(when on? (when on?
(send (get-top-level-window) update-info)))] (send (get-top-level-window) update-info)))]
[define set-editor [define set-editor
(lambda (m) (lambda (m)
(super-set-editor m) (super set-editor m)
(let ([tlw (get-top-level-window)]) (let ([tlw (get-top-level-window)])
(when (eq? this (send tlw get-info-canvas)) (when (eq? this (send tlw get-info-canvas))
(send tlw update-info))))] (send tlw update-info))))]
@ -70,7 +67,6 @@
(define wide-snip-mixin (define wide-snip-mixin
(mixin (basic<%>) (wide-snip<%>) (mixin (basic<%>) (wide-snip<%>)
(inherit get-editor) (inherit get-editor)
(rename [super-on-size on-size])
[define wide-snips null] [define wide-snips null]
[define tall-snips null] [define tall-snips null]
[define update-snip-size [define update-snip-size
@ -175,7 +171,7 @@
[define on-size [define on-size
(lambda (width height) (lambda (width height)
(recalc-snips) (recalc-snips)
(super-on-size width height))] (super on-size width height))]
(super-instantiate ()))) (super-instantiate ())))
(define basic% (basic-mixin editor-canvas%)) (define basic% (basic-mixin editor-canvas%))

3
collects/framework/private/color-prefs.ss
View File

@ -30,10 +30,9 @@
(stretchable-height #f))) (stretchable-height #f)))
(define e (new (class standard-style-list-text% (define e (new (class standard-style-list-text%
(inherit change-style get-style-list) (inherit change-style get-style-list)
(rename [super-after-insert after-insert])
(override after-insert) (override after-insert)
(define (after-insert pos offset) (define (after-insert pos offset)
(super-after-insert pos offset) (super after-insert pos offset)
(let ([style (send (get-style-list) (let ([style (send (get-style-list)
find-named-style find-named-style
style-name)]) style-name)])

59
collects/framework/private/color.ss
View File

@ -625,65 +625,56 @@
;; ------------------------- Callbacks to Override ---------------------- ;; ------------------------- Callbacks to Override ----------------------
(rename (super-lock lock))
(define/override (lock x) (define/override (lock x)
(super-lock x) (super lock x)
(when (and restart-callback (not x)) (when (and restart-callback (not x))
(set! restart-callback #f) (set! restart-callback #f)
(queue-callback (lambda () (colorer-callback))))) (queue-callback (lambda () (colorer-callback)))))
(rename (super-on-focus on-focus))
(define/override (on-focus on?) (define/override (on-focus on?)
(super-on-focus on?) (super on-focus on?)
(match-parens (not on?))) (match-parens (not on?)))
(rename (super-on-change on-change)) (define/augment (on-change)
(define/override (on-change) ;; >>> super was not here <<<
(modify)) (modify)
(inner (void) on-change))
(rename (super-after-edit-sequence after-edit-sequence)) (define/augment (after-edit-sequence)
(define/override (after-edit-sequence)
(super-after-edit-sequence)
(when (has-focus?) (when (has-focus?)
(match-parens))) (match-parens))
(inner (void) after-edit-sequence))
(rename (super-after-set-position after-set-position)) (define/augment (after-set-position)
(define/override (after-set-position)
(super-after-set-position)
(unless (local-edit-sequence?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(match-parens))) (match-parens)))
(modify)) (modify)
(inner (void) after-set-position))
(rename (super-after-change-style after-change-style)) (define/augment (after-change-style a b)
(define/override (after-change-style a b)
(super-after-change-style a b)
(unless (get-styles-fixed) (unless (get-styles-fixed)
(unless (local-edit-sequence?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(match-parens)))) (match-parens))))
(modify)) (modify)
(inner (void) after-change-style a b))
(rename (super-on-set-size-constraint on-set-size-constraint)) (define/augment (on-set-size-constraint)
(define/override (on-set-size-constraint)
(super-on-set-size-constraint)
(unless (local-edit-sequence?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(match-parens))) (match-parens)))
(modify)) (modify)
(inner (void) on-set-size-constraint))
(rename (super-after-insert after-insert)) (define/augment (after-insert edit-start-pos change-length)
(define/override (after-insert edit-start-pos change-length)
(do-insert/delete edit-start-pos change-length) (do-insert/delete edit-start-pos change-length)
(super-after-insert edit-start-pos change-length)) (inner (void) after-insert edit-start-pos change-length))
(rename (super-after-delete after-delete)) (define/augment (after-delete edit-start-pos change-length)
(define/override (after-delete edit-start-pos change-length)
(do-insert/delete edit-start-pos (- change-length)) (do-insert/delete edit-start-pos (- change-length))
(super-after-delete edit-start-pos change-length)) (inner (void) after-delete edit-start-pos change-length))
(rename (super-change-style change-style))
(super-new) (super-new)
@ -705,14 +696,12 @@
(token-sym->style (lambda (x) "Standard")) (token-sym->style (lambda (x) "Standard"))
(matches null)) (matches null))
(rename (super-on-disable-surrogate on-disable-surrogate))
(define/override (on-disable-surrogate text) (define/override (on-disable-surrogate text)
(super-on-disable-surrogate text) (super on-disable-surrogate text)
(send text stop-colorer)) (send text stop-colorer))
(rename (super-on-enable-surrogate on-enable-surrogate))
(define/override (on-enable-surrogate text) (define/override (on-enable-surrogate text)
(super-on-enable-surrogate text) (super on-enable-surrogate text)
(send text start-colorer token-sym->style get-token matches)) (send text start-colorer token-sym->style get-token matches))
(super-instantiate ()))) (super-instantiate ())))

7
collects/framework/private/comment-box.ss
View File

@ -16,6 +16,7 @@
(import [text : framework:text^] (import [text : framework:text^]
[scheme : framework:scheme^] [scheme : framework:scheme^]
[keymap : framework:keymap^]) [keymap : framework:keymap^])
(rename [-snip% snip%] (rename [-snip% snip%]
[-text% text%]) [-text% text%])
@ -33,9 +34,8 @@
(define (editor-keymap-mixin %) (define (editor-keymap-mixin %)
(class % (class %
(rename [super-get-keymaps get-keymaps])
(define/override (get-keymaps) (define/override (get-keymaps)
(cons (keymap:get-file) (super-get-keymaps))) (cons (keymap:get-file) (super get-keymaps)))
(super-instantiate ()))) (super-instantiate ())))
(define scheme+copy-self% #f) (define scheme+copy-self% #f)
@ -60,10 +60,9 @@
(define/override (get-corner-bitmap) bm) (define/override (get-corner-bitmap) bm)
(define/override (get-position) 'left-top) (define/override (get-position) 'left-top)
(rename [super-get-text get-text])
(define/override get-text (define/override get-text
(opt-lambda (offset num [flattened? #t]) (opt-lambda (offset num [flattened? #t])
(let* ([super-res (super-get-text offset num flattened?)] (let* ([super-res (super get-text offset num flattened?)]
[replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))]) [replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))])
(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1))) (if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
replaced replaced

81
collects/framework/private/editor.ss
View File

@ -48,7 +48,7 @@
(mixin (editor<%>) (basic<%>) (mixin (editor<%>) (basic<%>)
(define/public (can-close?) #t) (define/public (can-close?) #t)
(define/public (on-close) (void)) (define/pubment (on-close) (inner (void) on-close))
(define/public (close) (if (can-close?) (define/public (close) (if (can-close?)
(begin (on-close) #t) (begin (on-close) #t)
#f)) #f))
@ -124,8 +124,7 @@
get-canvas get-canvas
get-max-width get-admin) get-max-width get-admin)
(rename [super-can-save-file? can-save-file?]) (define/augment (can-save-file? filename format)
(define/override (can-save-file? filename format)
(and (if (equal? filename (get-filename)) (and (if (equal? filename (get-filename))
(if (save-file-out-of-date?) (if (save-file-out-of-date?)
(gui-utils:get-choice (gui-utils:get-choice
@ -137,13 +136,11 @@
(get-top-level-window)) (get-top-level-window))
#t) #t)
#t) #t)
(super-can-save-file? filename format))) (inner #t can-save-file? filename format)))
(rename [super-after-save-file after-save-file]
[super-after-load-file after-load-file])
(define last-saved-file-time #f) (define last-saved-file-time #f)
(define/override (after-save-file success?) (define/augment (after-save-file success?)
;; update recently opened file names ;; update recently opened file names
(let* ([temp-b (box #f)] (let* ([temp-b (box #f)]
[filename (get-filename temp-b)]) [filename (get-filename temp-b)])
@ -159,16 +156,16 @@
(file-exists? filename) (file-exists? filename)
(file-or-directory-modify-seconds filename))))) (file-or-directory-modify-seconds filename)))))
(super-after-save-file success?)) (inner (void) after-save-file success?))
(define/override (after-load-file success?) (define/augment (after-load-file success?)
(when success? (when success?
(let ([filename (get-filename)]) (let ([filename (get-filename)])
(set! last-saved-file-time (set! last-saved-file-time
(and filename (and filename
(file-exists? filename) (file-exists? filename)
(file-or-directory-modify-seconds filename))))) (file-or-directory-modify-seconds filename)))))
(super-after-load-file success?)) (inner (void) after-load-file success?))
(define/public (save-file-out-of-date?) (define/public (save-file-out-of-date?)
(and last-saved-file-time (and last-saved-file-time
(let ([fn (get-filename)]) (let ([fn (get-filename)])
@ -178,10 +175,9 @@
(< last-saved-file-time ms)))))) (< last-saved-file-time ms))))))
(define has-focus #f) (define has-focus #f)
(rename [super-on-focus on-focus])
(define/override (on-focus x) (define/override (on-focus x)
(set! has-focus x) (set! has-focus x)
(super-on-focus x)) (super on-focus x))
(define/public (has-focus?) has-focus) (define/public (has-focus?) has-focus)
(define/public (get-top-level-window) (define/public (get-top-level-window)
@ -243,17 +239,13 @@
edit-sequence-ht edit-sequence-ht
k t))) k t)))
(set! edit-sequence-queue (append l edit-sequence-queue)))] (set! edit-sequence-queue (append l edit-sequence-queue)))]
(rename [define/augment on-edit-sequence
[super-after-edit-sequence after-edit-sequence]
[super-on-edit-sequence on-edit-sequence])
[define/override on-edit-sequence
(lambda () (lambda ()
(super-on-edit-sequence) (set! in-local-edit-sequence? #t)
(set! in-local-edit-sequence? #t))] (inner (void) on-edit-sequence))]
[define/override after-edit-sequence [define/augment after-edit-sequence
(lambda () (lambda ()
(set! in-local-edit-sequence? #f) (set! in-local-edit-sequence? #f)
(super-after-edit-sequence)
(let ([queue edit-sequence-queue] (let ([queue edit-sequence-queue]
[ht edit-sequence-ht] [ht edit-sequence-ht]
[find-enclosing-editor [find-enclosing-editor
@ -276,7 +268,8 @@
(send editor extend-edit-sequence-queue queue ht)] (send editor extend-edit-sequence-queue queue ht)]
[else [else
(hash-table-for-each ht (lambda (k t) (t))) (hash-table-for-each ht (lambda (k t) (t)))
(for-each (lambda (t) (t)) queue)]))))] (for-each (lambda (t) (t)) queue)])))
(inner (void) after-edit-sequence))]
[define/override on-new-box [define/override on-new-box
(lambda (type) (lambda (type)
@ -401,10 +394,6 @@
(inherit get-filename lock get-style-list (inherit get-filename lock get-style-list
is-modified? change-style set-modified is-modified? change-style set-modified
get-top-level-window) get-top-level-window)
(rename [super-after-save-file after-save-file]
[super-after-load-file after-load-file]
[super-get-keymaps get-keymaps]
[super-set-filename set-filename])
(inherit get-canvases) (inherit get-canvases)
(define/private (check-lock) (define/private (check-lock)
@ -441,26 +430,25 @@
(unless untitled-name (unless untitled-name
(set! untitled-name (gui-utils:next-untitled-name))) (set! untitled-name (gui-utils:next-untitled-name)))
untitled-name)))) untitled-name))))
(define/override (after-save-file success) (define/augment (after-save-file success)
(when success (when success
(check-lock)) (check-lock))
(super-after-save-file success)) (inner (void) after-save-file success))
(define/override (after-load-file sucessful?) (define/augment (after-load-file sucessful?)
(when sucessful? (when sucessful?
(check-lock)) (check-lock))
(super-after-load-file sucessful?)) (inner (void) after-load-file sucessful?))
(define/override set-filename (define/override set-filename
(case-lambda (case-lambda
[(name) (set-filename name #f)] [(name) (set-filename name #f)]
[(name temp?) [(name temp?)
(super-set-filename name temp?) (super set-filename name temp?)
(unless temp? (unless temp?
(update-frame-filename))])) (update-frame-filename))]))
(inherit save-file) (inherit save-file)
(rename [super-can-close? can-close?])
(define/override (can-close?) (define/override (can-close?)
(let* ([user-allowed-or-not-modified (let* ([user-allowed-or-not-modified
(or (not (is-modified?)) (or (not (is-modified?))
@ -474,12 +462,12 @@
[(save) (save-file)] [(save) (save-file)]
[else #f]))]) [else #f]))])
(and user-allowed-or-not-modified (and user-allowed-or-not-modified
(super-can-close?)))) (super can-close?))))
(define/public (get-can-close-parent) #f) (define/public (get-can-close-parent) #f)
(define/override (get-keymaps) (define/override (get-keymaps)
(cons (keymap:get-file) (super-get-keymaps))) (cons (keymap:get-file) (super get-keymaps)))
(super-new))) (super-new)))
(define backup-autosave<%> (define backup-autosave<%>
@ -492,10 +480,6 @@
(define backup-autosave-mixin (define backup-autosave-mixin
(mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>) (mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>)
(inherit is-modified? get-filename save-file) (inherit is-modified? get-filename save-file)
(rename [super-on-save-file on-save-file]
[super-on-change on-change]
[super-on-close on-close]
[super-set-modified set-modified])
[define auto-saved-name #f] [define auto-saved-name #f]
[define auto-save-out-of-date? #t] [define auto-save-out-of-date? #t]
[define auto-save-error? #f] [define auto-save-error? #f]
@ -507,8 +491,7 @@
(< modified-seconds old-seconds)) (< modified-seconds old-seconds))
#t)) #t))
(define/public (backup?) (preferences:get 'framework:backup-files?)) (define/public (backup?) (preferences:get 'framework:backup-files?))
(define/override (on-save-file name format) (define/augment (on-save-file name format)
(super-on-save-file name format)
(set! auto-save-error? #f) (set! auto-save-error? #f)
(when (and (backup?) (when (and (backup?)
(not (eq? format 'copy)) (not (eq? format 'copy))
@ -519,20 +502,21 @@
(when (file-exists? back-name) (when (file-exists? back-name)
(delete-file back-name)) (delete-file back-name))
(with-handlers ([(lambda (x) #t) void]) (with-handlers ([(lambda (x) #t) void])
(copy-file name back-name)))))) (copy-file name back-name)))))
(define/override (on-close) (inner (void) on-save-file name format))
(super-on-close) (define/augment (on-close)
(remove-autosave) (remove-autosave)
(set! do-autosave? #f)) (set! do-autosave? #f)
(define/override (on-change) (inner (void) on-close))
(super-on-change) (define/augment (on-change)
(set! auto-save-out-of-date? #t)) (set! auto-save-out-of-date? #t)
(inner (void) on-change))
(define/override (set-modified modified?) (define/override (set-modified modified?)
(when auto-saved-name (when auto-saved-name
(if modified? (if modified?
(set! auto-save-out-of-date? #t) (set! auto-save-out-of-date? #t)
(remove-autosave))) (remove-autosave)))
(super-set-modified modified?)) (super set-modified modified?))
[define do-autosave? #t] [define do-autosave? #t]
(define/public (autosave?) do-autosave?) (define/public (autosave?) do-autosave?)
@ -598,10 +582,9 @@
(define info-mixin (define info-mixin
(mixin (basic<%>) (info<%>) (mixin (basic<%>) (info<%>)
(inherit get-top-level-window run-after-edit-sequence) (inherit get-top-level-window run-after-edit-sequence)
(rename [super-lock lock])
(define callback-running? #f) (define callback-running? #f)
(define/override (lock x) (define/override (lock x)
(super-lock x) (super lock x)
(run-after-edit-sequence (run-after-edit-sequence
(rec send-frame-update-lock-icon (rec send-frame-update-lock-icon
(lambda () (lambda ()

101
collects/framework/private/frame.ss
View File

@ -131,12 +131,11 @@
(define basic-mixin (define basic-mixin
(mixin ((class->interface frame%)) (basic<%>) (mixin ((class->interface frame%)) (basic<%>)
(rename [super-show show])
(define/override (show on?) (define/override (show on?)
(if on? (if on?
(send (group:get-the-frame-group) insert-frame this) (send (group:get-the-frame-group) insert-frame this)
(send (group:get-the-frame-group) remove-frame this)) (send (group:get-the-frame-group) remove-frame this))
(super-show on?)) (super show on?))
(define/override (can-exit?) (define/override (can-exit?)
(exit:set-exiting #t) (exit:set-exiting #t)
@ -159,10 +158,9 @@
(define/public (editing-this-file? filename) #f) (define/public (editing-this-file? filename) #f)
(rename [super-on-superwindow-show on-superwindow-show])
(define/override (on-superwindow-show shown?) (define/override (on-superwindow-show shown?)
(send (group:get-the-frame-group) frame-shown/hidden this) (send (group:get-the-frame-group) frame-shown/hidden this)
(super-on-superwindow-show shown?)) (super on-superwindow-show shown?))
(define after-init? #f) (define after-init? #f)
@ -214,22 +212,19 @@
(define register-group<%> (interface ())) (define register-group<%> (interface ()))
(define register-group-mixin (define register-group-mixin
(mixin (basic<%>) (register-group<%>) (mixin (basic<%>) (register-group<%>)
(rename [super-can-close? can-close?]
[super-on-close on-close]
[super-on-focus on-focus])
(define/override (can-close?) (define/override (can-close?)
(let ([number-of-frames (let ([number-of-frames
(length (send (group:get-the-frame-group) (length (send (group:get-the-frame-group)
get-frames))]) get-frames))])
(if (preferences:get 'framework:exit-when-no-frames) (if (preferences:get 'framework:exit-when-no-frames)
(and (super-can-close?) (and (super can-close?)
(or (exit:exiting?) (or (exit:exiting?)
(not (= 1 number-of-frames)) (not (= 1 number-of-frames))
(exit:user-oks-exit))) (exit:user-oks-exit)))
#t))) #t)))
(define/override (on-close) (define/override (on-close)
(super-on-close) (super on-close)
(send (group:get-the-frame-group) (send (group:get-the-frame-group)
remove-frame remove-frame
this) this)
@ -239,7 +234,7 @@
(exit:exit))))) (exit:exit)))))
(define/override (on-focus on?) (define/override (on-focus on?)
(super-on-focus on?) (super on-focus on?)
(when on? (when on?
(send (group:get-the-frame-group) set-active-frame this))) (send (group:get-the-frame-group) set-active-frame this)))
@ -306,9 +301,8 @@
;; status-line-msgs : (listof status-line-msg) ;; status-line-msgs : (listof status-line-msg)
[status-line-msgs null]) [status-line-msgs null])
(rename [super-make-root-area-container make-root-area-container])
(define/override (make-root-area-container % parent) (define/override (make-root-area-container % parent)
(let* ([s-root (super-make-root-area-container vertical-panel% parent)] (let* ([s-root (super make-root-area-container vertical-panel% parent)]
[r-root (make-object % s-root)]) [r-root (make-object % s-root)])
(set! status-line-container-panel (set! status-line-container-panel
(instantiate vertical-panel% () (instantiate vertical-panel% ()
@ -473,13 +467,12 @@
(define info-mixin (define info-mixin
(mixin (basic<%>) (info<%>) (mixin (basic<%>) (info<%>)
(rename [super-make-root-area-container make-root-area-container])
[define rest-panel 'uninitialized-root] [define rest-panel 'uninitialized-root]
[define super-root 'uninitialized-super-root] [define super-root 'uninitialized-super-root]
(override make-root-area-container) (override make-root-area-container)
[define make-root-area-container [define make-root-area-container
(lambda (% parent) (lambda (% parent)
(let* ([s-root (super-make-root-area-container (let* ([s-root (super make-root-area-container
vertical-panel% vertical-panel%
parent)] parent)]
[r-root (make-object % s-root)]) [r-root (make-object % s-root)])
@ -556,10 +549,9 @@
(update-info-visibility v)))] (update-info-visibility v)))]
[define memory-cleanup void] ;; only for CVSers and nightly build users; used with memory-text [define memory-cleanup void] ;; only for CVSers and nightly build users; used with memory-text
(rename [super-on-close on-close])
[define/override on-close [define/override on-close
(lambda () (lambda ()
(super-on-close) (super on-close)
(unregister-collecting-blit gc-canvas) (unregister-collecting-blit gc-canvas)
(close-panel-callback) (close-panel-callback)
(memory-cleanup))] (memory-cleanup))]
@ -703,10 +695,9 @@
(preferences:get 'framework:col-offsets) (preferences:get 'framework:col-offsets)
v) v)
#t))] #t))]
(rename [super-on-close on-close])
[define/override on-close [define/override on-close
(lambda () (lambda ()
(super-on-close) (super on-close)
(remove-first) (remove-first)
(remove-second))] (remove-second))]
[define last-start #f] [define last-start #f]
@ -845,11 +836,10 @@
(failed)])))] (failed)])))]
[else [else
(failed)])))] (failed)])))]
(rename [super-update-info update-info])
(override update-info) (override update-info)
[define update-info [define update-info
(lambda () (lambda ()
(super-update-info) (super update-info)
(update-macro-recording-icon) (update-macro-recording-icon)
(overwrite-status-changed) (overwrite-status-changed)
(anchor-status-changed) (anchor-status-changed)
@ -938,7 +928,6 @@
(inherit get-area-container get-client-size (inherit get-area-container get-client-size
show get-edit-target-window get-edit-target-object) show get-edit-target-window get-edit-target-object)
(rename [super-set-label set-label])
(define/override get-filename (define/override get-filename
(case-lambda (case-lambda
@ -956,20 +945,18 @@
(and this-fn (and this-fn
(path-equal? filename (get-filename)))))) (path-equal? filename (get-filename))))))
(rename [super-on-close on-close])
(define/override (on-close) (define/override (on-close)
(super-on-close) (super on-close)
(send (get-editor) on-close)) (send (get-editor) on-close))
(rename [super-can-close? can-close?])
(define/override (can-close?) (define/override (can-close?)
(and (super-can-close?) (and (super can-close?)
(send (get-editor) can-close?))) (send (get-editor) can-close?)))
[define label ""] [define label ""]
[define label-prefix (application:current-app-name)] [define label-prefix (application:current-app-name)]
(define (do-label) (define (do-label)
(super-set-label (gui-utils:trim-string (get-entire-label) 200)) (super set-label (gui-utils:trim-string (get-entire-label) 200))
(send (group:get-the-frame-group) frame-label-changed this)) (send (group:get-the-frame-group) frame-label-changed this))
(public get-entire-label get-label-prefix set-label-prefix) (public get-entire-label get-label-prefix set-label-prefix)
@ -1197,9 +1184,8 @@
(define open-here-mixin (define open-here-mixin
(mixin (-editor<%>) (open-here<%>) (mixin (-editor<%>) (open-here<%>)
(rename [super-file-menu:new-on-demand file-menu:new-on-demand])
(define/override (file-menu:new-on-demand item) (define/override (file-menu:new-on-demand item)
(super-file-menu:new-on-demand item) (super file-menu:new-on-demand item)
(send item set-label (if (preferences:get 'framework:open-here?) (send item set-label (if (preferences:get 'framework:open-here?)
(string-constant new-...-menu-item) (string-constant new-...-menu-item)
(string-constant new-menu-item)))) (string-constant new-menu-item))))
@ -1250,23 +1236,20 @@
'cancel 'cancel
this)) this))
(rename [super-file-menu:open-on-demand file-menu:open-on-demand])
(define/override (file-menu:open-on-demand item) (define/override (file-menu:open-on-demand item)
(super-file-menu:open-on-demand item) (super file-menu:open-on-demand item)
(send item set-label (if (preferences:get 'framework:open-here?) (send item set-label (if (preferences:get 'framework:open-here?)
(string-constant open-here-menu-item) (string-constant open-here-menu-item)
(string-constant open-menu-item)))) (string-constant open-menu-item))))
(rename [super-on-close on-close])
(define/override (on-close) (define/override (on-close)
(super-on-close) (super on-close)
(let ([group (group:get-the-frame-group)]) (let ([group (group:get-the-frame-group)])
(when (eq? this (send group get-open-here-frame)) (when (eq? this (send group get-open-here-frame))
(send group set-open-here-frame #f)))) (send group set-open-here-frame #f))))
(rename [super-on-activate on-activate])
(define/override (on-activate on?) (define/override (on-activate on?)
(super-on-activate on?) (super on-activate on?)
(when on? (when on?
(send (group:get-the-frame-group) set-open-here-frame this))) (send (group:get-the-frame-group) set-open-here-frame this)))
@ -1335,12 +1318,11 @@
(define delegatee-editor-canvas% (define delegatee-editor-canvas%
(class editor-canvas% (class editor-canvas%
(rename [super-on-event on-event])
(init-field delegate-frame) (init-field delegate-frame)
(inherit get-editor get-dc) (inherit get-editor get-dc)
(define/override (on-event evt) (define/override (on-event evt)
(super-on-event evt) (super on-event evt)
(when delegate-frame (when delegate-frame
(let ([text (get-editor)]) (let ([text (get-editor)])
(when (is-a? text text%) (when (is-a? text text%)
@ -1379,7 +1361,6 @@
(define delegatee-text% (define delegatee-text%
(class* text:basic% (delegatee-text<%>) (class* text:basic% (delegatee-text<%>)
(rename [super-on-paint on-paint])
(inherit get-admin) (inherit get-admin)
(define start-para #f) (define start-para #f)
(define end-para #f) (define end-para #f)
@ -1433,7 +1414,7 @@
(invalidate-bitmap-cache x y w h))))))) (invalidate-bitmap-cache x y w h)))))))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super-on-paint before? dc left top right bottom dx dy draw-caret) (super on-paint before? dc left top right bottom dx dy draw-caret)
(when (and before? (when (and before?
start-para start-para
end-para) end-para)
@ -1492,13 +1473,12 @@
(define/public (get-delegated-text) (get-editor)) (define/public (get-delegated-text) (get-editor))
(rename [super-make-root-area-container make-root-area-container])
[define rest-panel 'uninitialized-root] [define rest-panel 'uninitialized-root]
[define super-root 'uninitialized-super-root] [define super-root 'uninitialized-super-root]
(override make-root-area-container) (override make-root-area-container)
[define make-root-area-container [define make-root-area-container
(lambda (% parent) (lambda (% parent)
(let* ([s-root (super-make-root-area-container (let* ([s-root (super make-root-area-container
horizontal-panel% horizontal-panel%
parent)] parent)]
[r-root (make-object % s-root)]) [r-root (make-object % s-root)])
@ -1506,13 +1486,11 @@
(set! rest-panel r-root) (set! rest-panel r-root)
r-root))] r-root))]
(rename [super-get-editor<%> get-editor<%>])
(define/override (get-editor<%>) (define/override (get-editor<%>)
text:delegate<%>) text:delegate<%>)
(rename [super-get-editor% get-editor%])
(define/override (get-editor%) (define/override (get-editor%)
(text:delegate-mixin (super-get-editor%))) (text:delegate-mixin (super get-editor%)))
(field (shown? (preferences:get 'framework:show-delegate?))) (field (shown? (preferences:get 'framework:show-delegate?)))
(define/public (delegated-text-shown?) (define/public (delegated-text-shown?)
@ -1605,12 +1583,11 @@
[text-keymap/editor% [text-keymap/editor%
(class text:keymap% (class text:keymap%
(rename [super-get-keymaps get-keymaps])
(define/override (get-keymaps) (define/override (get-keymaps)
(if (preferences:get 'framework:menu-bindings) (if (preferences:get 'framework:menu-bindings)
(append (list (keymap:get-editor)) (append (list (keymap:get-editor))
(super-get-keymaps)) (super get-keymaps))
(append (super-get-keymaps) (append (super get-keymaps)
(list (keymap:get-editor))))) (list (keymap:get-editor)))))
(inherit set-styles-fixed) (inherit set-styles-fixed)
(super-new) (super-new)
@ -1852,9 +1829,6 @@
(define find-text% (define find-text%
(class text:keymap% (class text:keymap%
(inherit get-text) (inherit get-text)
(rename [super-after-insert after-insert]
[super-after-delete after-delete]
[super-on-focus on-focus])
(define/private (get-searching-edit) (define/private (get-searching-edit)
(and searching-frame (and searching-frame
(send searching-frame get-text-to-search))) (send searching-frame get-text-to-search)))
@ -1928,15 +1902,15 @@
(let ([edit (get-searching-edit)]) (let ([edit (get-searching-edit)])
(when edit (when edit
(reset-search-anchor (get-searching-edit))))) (reset-search-anchor (get-searching-edit)))))
(super-on-focus on?)) (super on-focus on?))
(define/override (after-insert x y) (define/augment (after-insert x y)
(super-after-insert x y)
(unless dont-search (unless dont-search
(search #f))) (search #f))
(define/override (after-delete x y) (inner (void) after-insert x y))
(super-after-delete x y) (define/augment (after-delete x y)
(unless dont-search (unless dont-search
(search #f))) (search #f))
(inner (void) after-delete x y))
(super-new) (super-new)
(inherit set-styles-fixed) (inherit set-styles-fixed)
(set-styles-fixed #t))) (set-styles-fixed #t)))
@ -1953,11 +1927,10 @@
(define searchable-canvas% (define searchable-canvas%
(class editor-canvas% (class editor-canvas%
(inherit get-top-level-window set-line-count) (inherit get-top-level-window set-line-count)
(rename [super-on-focus on-focus])
(define/override (on-focus x) (define/override (on-focus x)
(when x (when x
(set-searching-frame (get-top-level-window))) (set-searching-frame (get-top-level-window)))
(super-on-focus x)) (super on-focus x))
(super-new (style '(hide-hscroll hide-vscroll))) (super-new (style '(hide-hscroll hide-vscroll)))
(set-line-count 2))) (set-line-count 2)))
@ -1975,9 +1948,6 @@
(define searchable-mixin (define searchable-mixin
(mixin (standard-menus<%>) (searchable<%>) (mixin (standard-menus<%>) (searchable<%>)
(init-find/replace-edits) (init-find/replace-edits)
(rename [super-make-root-area-container make-root-area-container]
[super-on-activate on-activate]
[super-on-close on-close])
(define super-root 'unitiaialized-super-root) (define super-root 'unitiaialized-super-root)
(override edit-menu:find-callback edit-menu:create-find? (override edit-menu:find-callback edit-menu:create-find?
edit-menu:find-again-callback edit-menu:create-find-again? edit-menu:find-again-callback edit-menu:create-find-again?
@ -1994,7 +1964,7 @@
(override make-root-area-container) (override make-root-area-container)
(define make-root-area-container (define make-root-area-container
(lambda (% parent) (lambda (% parent)
(let* ([s-root (super-make-root-area-container (let* ([s-root (super make-root-area-container
vertical-panel% vertical-panel%
parent)] parent)]
[root (make-object % s-root)]) [root (make-object % s-root)])
@ -2007,7 +1977,7 @@
(if on? (if on?
(reset-search-anchor (get-text-to-search)) (reset-search-anchor (get-text-to-search))
(clear-search-highlight))) (clear-search-highlight)))
(super-on-activate on?))) (super on-activate on?)))
(define/public (get-text-to-search) (define/public (get-text-to-search)
(error 'get-text-to-search "abstract method in searchable-mixin")) (error 'get-text-to-search "abstract method in searchable-mixin"))
@ -2072,7 +2042,7 @@
(hide-search))))) (hide-search)))))
(define/override on-close (define/override on-close
(lambda () (lambda ()
(super-on-close) (super on-close)
(remove-callback) (remove-callback)
(let ([close-canvas (let ([close-canvas
(lambda (canvas edit) (lambda (canvas edit)
@ -2323,14 +2293,13 @@
(define bday-click-canvas% (define bday-click-canvas%
(class canvas% (class canvas%
(rename [super-on-event on-event])
(define/override (on-event evt) (define/override (on-event evt)
(cond (cond
[(and (mrf-bday?) [(and (mrf-bday?)
(send evt button-up?)) (send evt button-up?))
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant happy-birthday-matthew))] (string-constant happy-birthday-matthew))]
[else (super-on-event evt)])) [else (super on-event evt)]))
(super-instantiate ()))) (super-instantiate ())))
(define basic% (register-group-mixin (basic-mixin frame%))) (define basic% (register-group-mixin (basic-mixin frame%)))

3
collects/framework/private/handler.ss
View File

@ -319,9 +319,8 @@
(lambda (p v) (lambda (p v)
(refresh-hl v)))]) (refresh-hl v)))])
(rename [super-on-close on-close])
(define/override (on-close) (define/override (on-close)
(super-on-close) (super on-close)
(remove-prefs-callback) (remove-prefs-callback)
(set! recent-items-window #f)) (set! recent-items-window #f))

9
collects/framework/private/keymap.ss
View File

@ -62,27 +62,24 @@
(lambda () (lambda ()
chained-keymaps)] chained-keymaps)]
(rename [super-chain-to-keymap chain-to-keymap])
(define/override (chain-to-keymap keymap prefix?) (define/override (chain-to-keymap keymap prefix?)
(super-chain-to-keymap keymap prefix?) (super chain-to-keymap keymap prefix?)
(set! chained-keymaps (set! chained-keymaps
(if prefix? (if prefix?
(cons keymap chained-keymaps) (cons keymap chained-keymaps)
(append chained-keymaps (list keymap))))) (append chained-keymaps (list keymap)))))
(rename [super-remove-chained-keymap remove-chained-keymap])
(define/override (remove-chained-keymap keymap) (define/override (remove-chained-keymap keymap)
(super-remove-chained-keymap keymap) (super remove-chained-keymap keymap)
(set! chained-keymaps (remq keymap chained-keymaps))) (set! chained-keymaps (remq keymap chained-keymaps)))
[define function-table (make-hash-table)] [define function-table (make-hash-table)]
(public get-function-table) (public get-function-table)
[define get-function-table (lambda () function-table)] [define get-function-table (lambda () function-table)]
(rename [super-map-function map-function])
(override map-function) (override map-function)
[define map-function [define map-function
(lambda (keyname fname) (lambda (keyname fname)
(super-map-function (canonicalize-keybinding-string keyname) fname) (super map-function (canonicalize-keybinding-string keyname) fname)
(hash-table-put! function-table (string->symbol keyname) fname))] (hash-table-put! function-table (string->symbol keyname) fname))]
(public get-map-function-table get-map-function-table/ht) (public get-map-function-table get-map-function-table/ht)

75
collects/framework/private/mode.ss
View File

@ -1,6 +1,7 @@
(module mode mzscheme (module mode mzscheme
(require (lib "surrogate.ss") (require (lib "surrogate.ss")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "class.ss")
"sig.ss") "sig.ss")
(provide mode@) (provide mode@)
@ -11,43 +12,43 @@
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>) (define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
(surrogate (surrogate
(on-change ()) (augment (void) on-change ())
(on-char (event)) (override on-char (event))
(on-default-char (event)) (override on-default-char (event))
(on-default-event (event)) (override on-default-event (event))
(on-display-size ()) (augment (void) on-display-size ())
(on-edit-sequence ()) (augment (void) on-edit-sequence ())
(on-event (event)) (override on-event (event))
(on-focus (on?)) (override on-focus (on?))
(on-load-file (filename format)) (augment (void) on-load-file (filename format))
(on-local-char (event)) (override on-local-char (event))
(on-local-event (event)) (override on-local-event (event))
(on-new-box (type)) (override on-new-box (type))
(on-new-image-snip (filename kind relative-path? inline?)) (override on-new-image-snip (filename kind relative-path? inline?))
(on-paint (before? dc left top right bottom dx dy draw-caret)) (override on-paint (before? dc left top right bottom dx dy draw-caret))
(on-save-file (filename format)) (augment (void) on-save-file (filename format))
(on-snip-modified (snip modified?)) (augment (void) on-snip-modified (snip modified?))
(on-change-style (start len)) (augment (void) on-change-style (start len))
(on-delete (start len)) (augment (void) on-delete (start len))
(on-insert (start len)) (augment (void) on-insert (start len))
(on-new-string-snip ()) (override on-new-string-snip ())
(on-new-tab-snip ()) (override on-new-tab-snip ())
(on-set-size-constraint ()) (augment (void) on-set-size-constraint ())
(after-change-style (start len)) (augment (void) after-change-style (start len))
(after-delete (start len)) (augment (void) after-delete (start len))
(after-insert (start len)) (augment (void) after-insert (start len))
(after-set-position ()) (augment (void) after-set-position ())
(after-set-size-constraint ()) (augment (void) after-set-size-constraint ())
(after-edit-sequence ()) (augment (void) after-edit-sequence ())
(after-load-file (success?)) (augment (void) after-load-file (success?))
(after-save-file (success?)) (augment (void) after-save-file (success?))
(can-change-style? (start len)) (augment #f can-change-style? (start len))
(can-delete? (start len)) (augment #f can-delete? (start len))
(can-insert? (start len)) (augment #f can-insert? (start len))
(can-set-size-constraint? ()) (augment #f can-set-size-constraint? ())
(can-do-edit-operation? (op) (op recursive?)) (augment #f can-do-edit-operation? (op recursive?))
(can-load-file? (filename format)) (augment #f can-load-file? (filename format))
(can-save-file? (filename format))))))) (augment #f can-save-file? (filename format)))))))

11
collects/framework/private/panel.ss
View File

@ -15,7 +15,6 @@
(import [icon : framework:icon^] (import [icon : framework:icon^]
mred^) mred^)
(rename [-editor<%> editor<%>])
(define (list-set! _list _i ele) (define (list-set! _list _i ele)
(let loop ([lst _list] (let loop ([lst _list]
@ -30,7 +29,6 @@
(define single-mixin (define single-mixin
(mixin (area-container<%>) (single<%>) (mixin (area-container<%>) (single<%>)
(inherit get-alignment change-children) (inherit get-alignment change-children)
(rename [super-after-new-child after-new-child])
(define/override (after-new-child c) (define/override (after-new-child c)
(unless (is-a? c window<%>) (unless (is-a? c window<%>)
@ -98,11 +96,10 @@
(define single-window-mixin (define single-window-mixin
(mixin (single<%> window<%>) (single-window<%>) (mixin (single<%> window<%>) (single-window<%>)
(inherit get-client-size get-size) (inherit get-client-size get-size)
(rename [super-container-size container-size])
(override container-size) (override container-size)
[define container-size [define container-size
(lambda (l) (lambda (l)
(let-values ([(super-width super-height) (super-container-size l)] (let-values ([(super-width super-height) (super container-size l)]
[(client-width client-height) (get-client-size)] [(client-width client-height) (get-client-size)]
[(window-width window-height) (get-size)] [(window-width window-height) (get-size)]
[(calc-size) [(calc-size)
@ -282,7 +279,6 @@
(define resizing-dim #f) (define resizing-dim #f)
(define resizing-gap #f) (define resizing-gap #f)
(rename [super-on-subwindow-event on-subwindow-event])
(inherit set-cursor) (inherit set-cursor)
(define/override (on-subwindow-event receiver evt) (define/override (on-subwindow-event receiver evt)
(if (eq? receiver this) (if (eq? receiver this)
@ -322,14 +318,13 @@
(after-percentage-change) (after-percentage-change)
(set! resizing-dim (event-get-dim evt)) (set! resizing-dim (event-get-dim evt))
(container-flow-modified))))] (container-flow-modified))))]
[else (super-on-subwindow-event receiver evt)])) [else (super on-subwindow-event receiver evt)]))
(begin (begin
(set-cursor #f) (set-cursor #f)
(super-on-subwindow-event receiver evt)))) (super on-subwindow-event receiver evt))))
(define cursor-gaps null) (define cursor-gaps null)
(rename [super-place-children place-children])
(define/override (place-children _infos width height) (define/override (place-children _infos width height)
(set! cursor-gaps null) (set! cursor-gaps null)
(update-percentages) (update-percentages)

3
collects/framework/private/preferences.ss
View File

@ -454,11 +454,10 @@
(letrec ([stashed-prefs (get-disk-prefs/install (lambda () null))] (letrec ([stashed-prefs (get-disk-prefs/install (lambda () null))]
[frame-stashed-prefs% [frame-stashed-prefs%
(class frame:basic% (class frame:basic%
(rename [super-show show])
(define/override (show on?) (define/override (show on?)
(when on? (when on?
(set! stashed-prefs (get-disk-prefs/install (lambda () null)))) (set! stashed-prefs (get-disk-prefs/install (lambda () null))))
(super-show on?)) (super show on?))
(super-instantiate ()))] (super-instantiate ()))]
[frame [frame
(make-object frame-stashed-prefs% (make-object frame-stashed-prefs%

9
collects/framework/private/scheme.ss
View File

@ -86,7 +86,6 @@
1 1
#t))) #t)))
(rename [super-get-text get-text])
(define/override get-text (define/override get-text
(opt-lambda (offset num [flattened? #f]) (opt-lambda (offset num [flattened? #f])
(if flattened? (if flattened?
@ -94,7 +93,7 @@
(map (lambda (snip) (map (lambda (snip)
(send snip get-text 0 (send snip get-count) flattened?)) (send snip get-text 0 (send snip get-count) flattened?))
saved-snips)) saved-snips))
(super-get-text offset num flattened?)))) (super get-text offset num flattened?))))
(define/override (copy) (define/override (copy)
(instantiate sexp-snip% () (instantiate sexp-snip% ()
@ -940,15 +939,13 @@
(define text-mode-mixin (define text-mode-mixin
(mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>) (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
(rename [super-on-disable-surrogate on-disable-surrogate])
(define/override (on-disable-surrogate text) (define/override (on-disable-surrogate text)
(keymap:remove-chained-keymap text keymap) (keymap:remove-chained-keymap text keymap)
(super-on-disable-surrogate text)) (super on-disable-surrogate text))
(rename [super-on-enable-surrogate on-enable-surrogate])
(define/override (on-enable-surrogate text) (define/override (on-enable-surrogate text)
(send text begin-edit-sequence) (send text begin-edit-sequence)
(super-on-enable-surrogate text) (super on-enable-surrogate text)
(send (send text get-keymap) chain-to-keymap keymap #t) (send (send text get-keymap) chain-to-keymap keymap #t)
;; I don't know about these editor flag settings. ;; I don't know about these editor flag settings.

1
collects/framework/private/version.ss
View File

@ -10,7 +10,6 @@
(define version@ (define version@
(unit/sig framework:version^ (unit/sig framework:version^
(import) (import)
(rename [-version version]) (rename [-version version])
(define specs null) (define specs null)