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)]
(inherit get-admin)
(rename [super-on-event on-event])
(define/override (on-event dc x y editorx editory evt)
(cond
[(send evt get-right-down)
@ -67,12 +66,11 @@
(let ([admin (get-admin)])
(when admin
(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
(super-on-event dc x y editorx editory evt)]))
(super on-event dc x y editorx editory evt)]))
(inherit get-extent get-inset)
(rename [super-draw draw])
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([bm (get-corner-bitmap)]
[bil (box 0)]
@ -88,7 +86,7 @@
(get-extent dc x y bw bh #f #f #f #f)
(get-inset bil bit bir bib)
(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)]
[old-brush (send dc get-brush)])

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

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

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

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

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

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

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

@ -23,7 +23,7 @@
[text : framework:text^]
[color-prefs : framework:color-prefs^]
[scheme : framework:scheme^])
(rename [-text<%> text<%>]
[-text% text%]
[-text-mode<%> text-mode<%>])
@ -625,66 +625,57 @@
;; ------------------------- Callbacks to Override ----------------------
(rename (super-lock lock))
(define/override (lock x)
(super-lock x)
(super lock x)
(when (and restart-callback (not x))
(set! restart-callback #f)
(queue-callback (lambda () (colorer-callback)))))
(rename (super-on-focus on-focus))
(define/override (on-focus on?)
(super-on-focus on?)
(super on-focus on?)
(match-parens (not on?)))
(rename (super-on-change on-change))
(define/override (on-change)
(modify))
(define/augment (on-change)
;; >>> super was not here <<<
(modify)
(inner (void) on-change))
(rename (super-after-edit-sequence after-edit-sequence))
(define/override (after-edit-sequence)
(super-after-edit-sequence)
(define/augment (after-edit-sequence)
(when (has-focus?)
(match-parens)))
(match-parens))
(inner (void) after-edit-sequence))
(rename (super-after-set-position after-set-position))
(define/override (after-set-position)
(super-after-set-position)
(define/augment (after-set-position)
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(modify))
(modify)
(inner (void) after-set-position))
(rename (super-after-change-style after-change-style))
(define/override (after-change-style a b)
(super-after-change-style a b)
(define/augment (after-change-style a b)
(unless (get-styles-fixed)
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens))))
(modify))
(modify)
(inner (void) after-change-style a b))
(rename (super-on-set-size-constraint on-set-size-constraint))
(define/override (on-set-size-constraint)
(super-on-set-size-constraint)
(define/augment (on-set-size-constraint)
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(modify))
(modify)
(inner (void) on-set-size-constraint))
(rename (super-after-insert after-insert))
(define/override (after-insert edit-start-pos change-length)
(define/augment (after-insert 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/override (after-delete edit-start-pos change-length)
(define/augment (after-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)
;; need pref-callback to be in a private field
@ -705,14 +696,12 @@
(token-sym->style (lambda (x) "Standard"))
(matches null))
(rename (super-on-disable-surrogate on-disable-surrogate))
(define/override (on-disable-surrogate text)
(super-on-disable-surrogate text)
(super on-disable-surrogate text)
(send text stop-colorer))
(rename (super-on-enable-surrogate on-enable-surrogate))
(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))
(super-instantiate ())))

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

@ -16,9 +16,10 @@
(import [text : framework:text^]
[scheme : framework:scheme^]
[keymap : framework:keymap^])
(rename [-snip% snip%]
[-text% text%])
(rename [-snip% snip%]
[-text% text%])
(define snipclass%
(class decorated-editor-snipclass%
(define/override (make-snip stream-in) (instantiate -snip% ()))
@ -33,9 +34,8 @@
(define (editor-keymap-mixin %)
(class %
(rename [super-get-keymaps get-keymaps])
(define/override (get-keymaps)
(cons (keymap:get-file) (super-get-keymaps)))
(cons (keymap:get-file) (super get-keymaps)))
(super-instantiate ())))
(define scheme+copy-self% #f)
@ -60,10 +60,9 @@
(define/override (get-corner-bitmap) bm)
(define/override (get-position) 'left-top)
(rename [super-get-text get-text])
(define/override get-text
(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; "))])
(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
replaced

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

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

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

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

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

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

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

@ -62,27 +62,24 @@
(lambda ()
chained-keymaps)]
(rename [super-chain-to-keymap chain-to-keymap])
(define/override (chain-to-keymap keymap prefix?)
(super-chain-to-keymap keymap prefix?)
(super chain-to-keymap keymap prefix?)
(set! chained-keymaps
(if prefix?
(cons keymap chained-keymaps)
(append chained-keymaps (list keymap)))))
(rename [super-remove-chained-keymap remove-chained-keymap])
(define/override (remove-chained-keymap keymap)
(super-remove-chained-keymap keymap)
(super remove-chained-keymap keymap)
(set! chained-keymaps (remq keymap chained-keymaps)))
[define function-table (make-hash-table)]
(public get-function-table)
[define get-function-table (lambda () function-table)]
(rename [super-map-function map-function])
(override map-function)
[define map-function
(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))]
(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
(require (lib "surrogate.ss")
(lib "unitsig.ss")
(lib "class.ss")
"sig.ss")
(provide mode@)
@ -11,43 +12,43 @@
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
(surrogate
(on-change ())
(on-char (event))
(on-default-char (event))
(on-default-event (event))
(on-display-size ())
(on-edit-sequence ())
(on-event (event))
(on-focus (on?))
(on-load-file (filename format))
(on-local-char (event))
(on-local-event (event))
(on-new-box (type))
(on-new-image-snip (filename kind relative-path? inline?))
(on-paint (before? dc left top right bottom dx dy draw-caret))
(on-save-file (filename format))
(on-snip-modified (snip modified?))
(augment (void) on-change ())
(override on-char (event))
(override on-default-char (event))
(override on-default-event (event))
(augment (void) on-display-size ())
(augment (void) on-edit-sequence ())
(override on-event (event))
(override on-focus (on?))
(augment (void) on-load-file (filename format))
(override on-local-char (event))
(override on-local-event (event))
(override on-new-box (type))
(override on-new-image-snip (filename kind relative-path? inline?))
(override on-paint (before? dc left top right bottom dx dy draw-caret))
(augment (void) on-save-file (filename format))
(augment (void) on-snip-modified (snip modified?))
(on-change-style (start len))
(on-delete (start len))
(on-insert (start len))
(on-new-string-snip ())
(on-new-tab-snip ())
(on-set-size-constraint ())
(augment (void) on-change-style (start len))
(augment (void) on-delete (start len))
(augment (void) on-insert (start len))
(override on-new-string-snip ())
(override on-new-tab-snip ())
(augment (void) on-set-size-constraint ())
(after-change-style (start len))
(after-delete (start len))
(after-insert (start len))
(after-set-position ())
(after-set-size-constraint ())
(after-edit-sequence ())
(after-load-file (success?))
(after-save-file (success?))
(augment (void) after-change-style (start len))
(augment (void) after-delete (start len))
(augment (void) after-insert (start len))
(augment (void) after-set-position ())
(augment (void) after-set-size-constraint ())
(augment (void) after-edit-sequence ())
(augment (void) after-load-file (success?))
(augment (void) after-save-file (success?))
(can-change-style? (start len))
(can-delete? (start len))
(can-insert? (start len))
(can-set-size-constraint? ())
(can-do-edit-operation? (op) (op recursive?))
(can-load-file? (filename format))
(can-save-file? (filename format)))))))
(augment #f can-change-style? (start len))
(augment #f can-delete? (start len))
(augment #f can-insert? (start len))
(augment #f can-set-size-constraint? ())
(augment #f can-do-edit-operation? (op recursive?))
(augment #f can-load-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^]
mred^)
(rename [-editor<%> editor<%>])
(define (list-set! _list _i ele)
(let loop ([lst _list]
@ -30,7 +29,6 @@
(define single-mixin
(mixin (area-container<%>) (single<%>)
(inherit get-alignment change-children)
(rename [super-after-new-child after-new-child])
(define/override (after-new-child c)
(unless (is-a? c window<%>)
@ -98,11 +96,10 @@
(define single-window-mixin
(mixin (single<%> window<%>) (single-window<%>)
(inherit get-client-size get-size)
(rename [super-container-size container-size])
(override container-size)
[define container-size
(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)]
[(window-width window-height) (get-size)]
[(calc-size)
@ -282,7 +279,6 @@
(define resizing-dim #f)
(define resizing-gap #f)
(rename [super-on-subwindow-event on-subwindow-event])
(inherit set-cursor)
(define/override (on-subwindow-event receiver evt)
(if (eq? receiver this)
@ -322,14 +318,13 @@
(after-percentage-change)
(set! resizing-dim (event-get-dim evt))
(container-flow-modified))))]
[else (super-on-subwindow-event receiver evt)]))
[else (super on-subwindow-event receiver evt)]))
(begin
(set-cursor #f)
(super-on-subwindow-event receiver evt))))
(super on-subwindow-event receiver evt))))
(define cursor-gaps null)
(rename [super-place-children place-children])
(define/override (place-children _infos width height)
(set! cursor-gaps null)
(update-percentages)

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

@ -19,7 +19,7 @@
[exit : framework:exit^]
[panel : framework:panel^]
[frame : framework:frame^])
(rename [-read read])
(define main-preferences-symbol 'plt:framework-prefs)
@ -454,11 +454,10 @@
(letrec ([stashed-prefs (get-disk-prefs/install (lambda () null))]
[frame-stashed-prefs%
(class frame:basic%
(rename [super-show show])
(define/override (show on?)
(when on?
(set! stashed-prefs (get-disk-prefs/install (lambda () null))))
(super-show on?))
(super show on?))
(super-instantiate ()))]
[frame
(make-object frame-stashed-prefs%

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

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

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

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