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

.

Browse Source 
original commit: 2f1ab3140f048976e85ed9bcc30194f09d8909ee
This commit is contained in:
Robby Findler 2004-07-04 23:41:57 +00:00
parent d8007afac2
commit 10bebd4c0f
5 changed files with 72 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -33,21 +33,18 @@
(define info-mixin
(mixin (basic<%>) (info<%>)
(inherit has-focus? get-top-level-window)
(override on-focus set-editor)
[define on-focus
(lambda (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)
(let ([tlw (get-top-level-window)])
(when (eq? this (send tlw get-info-canvas))
(send tlw update-info))))]
(super-instantiate ())
(define/override (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/override (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))))
(super-new)
(unless (is-a? (get-top-level-window) frame:info<%>)
(error 'canvas:text-info-mixin
@ -167,12 +164,10 @@
(lambda (snip)
(set! tall-snips (cons snip tall-snips))
((update-snip-size #f) snip))]
(override on-size)
[define on-size
(lambda (width height)
(recalc-snips)
(super on-size width height))]
(super-instantiate ())))
(define/override (on-size width height)
(recalc-snips)
(super on-size width height))
(super-new)))
(define basic% (basic-mixin editor-canvas%))
(define info% (info-mixin basic%))

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

@ -469,16 +469,14 @@
(mixin (basic<%>) (info<%>)
[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
vertical-panel%
parent)]
[r-root (make-object % s-root)])
(set! super-root s-root)
(set! rest-panel r-root)
r-root))]
(define/override (make-root-area-container % parent)
(let* ([s-root (super make-root-area-container
vertical-panel%
parent)]
[r-root (make-object % s-root)])
(set! super-root s-root)
(set! rest-panel r-root)
r-root))
[define info-canvas #f]
(public get-info-canvas set-info-canvas get-info-editor)
@ -836,8 +834,7 @@
(failed)])))]
[else
(failed)])))]
(override update-info)
[define update-info
[define/override update-info
(lambda ()
(super update-info)
(update-macro-recording-icon)
@ -976,9 +973,8 @@
(not (string=? s label-prefix)))
(set! label-prefix s)
(do-label)))]
(override get-label set-label)
[define get-label (lambda () label)]
[define set-label
[define/override get-label (lambda () label)]
[define/override set-label
(lambda (t)
(when (and (string? t)
(not (string=? t label)))
@ -1036,10 +1032,7 @@
base))
(inherit get-checkable-menu-item% get-menu-item%)
(override file-menu:save-callback
file-menu:create-save? file-menu:save-as-callback file-menu:create-save-as?
file-menu:print-callback file-menu:create-print?)
(define/override (file-menu:revert-on-demand item)
(send item enable (not (send (get-editor) is-locked?))))
@ -1084,23 +1077,23 @@
(send edit end-edit-sequence)))))))
(define/override file-menu:create-revert? (lambda () #t))
(define file-menu:save-callback (lambda (item control)
(save)
#t))
(define/override file-menu:save-callback
(lambda (item control)
(save)
#t))
(define file-menu:create-save? (lambda () #t))
(define file-menu:save-as-callback (lambda (item control) (save-as) #t))
(define file-menu:create-save-as? (lambda () #t))
(define file-menu:print-callback (lambda (item control)
(define/override file-menu:create-save? (lambda () #t))
(define/override file-menu:save-as-callback (lambda (item control) (save-as) #t))
(define/override file-menu:create-save-as? (lambda () #t))
(define/override file-menu:print-callback (lambda (item control)
(send (get-editor) print
#t
#t
(preferences:get 'framework:print-output-mode))
#t))
(define file-menu:create-print? (lambda () #t))
(define/override file-menu:create-print? (lambda () #t))
(override edit-menu:between-select-all-and-find)
(define edit-menu:between-select-all-and-find
(define/override edit-menu:between-select-all-and-find
(lambda (edit-menu)
(let* ([c% (get-checkable-menu-item%)]
[on-demand
@ -1126,18 +1119,17 @@
(make-object separator-menu-item% edit-menu)))
(override help-menu:about-callback help-menu:about-string help-menu:create-about?)
(define help-menu:about-callback
(define/override help-menu:about-callback
(lambda (menu evt)
(message-box (application:current-app-name)
(format (string-constant welcome-to-something)
(application:current-app-name))
#f
'(ok app))))
(define help-menu:about-string (lambda () (application:current-app-name)))
(define help-menu:create-about? (lambda () #t))
(define/override help-menu:about-string (lambda () (application:current-app-name)))
(define/override help-menu:create-about? (lambda () #t))
(super-instantiate () (label (get-entire-label)))
(super-new (label (get-entire-label)))
(define canvas #f)
(define editor #f)
@ -1295,18 +1287,16 @@
(define text<%> (interface (-editor<%>)))
(define text-mixin
(mixin (-editor<%>) (text<%>)
(override get-editor<%> get-editor%)
[define get-editor<%> (lambda () (class->interface text%))]
[define get-editor% (lambda () text:keymap%)]
(super-instantiate ())))
[define/override get-editor<%> (lambda () (class->interface text%))]
[define/override get-editor% (lambda () text:keymap%)]
(super-new)))
(define pasteboard<%> (interface (-editor<%>)))
(define pasteboard-mixin
(mixin (-editor<%>) (pasteboard<%>)
(override get-editor<%> get-editor%)
[define get-editor<%> (lambda () (class->interface pasteboard%))]
[define get-editor% (lambda () pasteboard:keymap%)]
(super-instantiate ())))
[define/override get-editor<%> (lambda () (class->interface pasteboard%))]
[define/override get-editor% (lambda () pasteboard:keymap%)]
(super-new)))
(define delegate<%>
(interface (status-line<%> text<%>)
@ -1475,8 +1465,7 @@
[define rest-panel 'uninitialized-root]
[define super-root 'uninitialized-super-root]
(override make-root-area-container)
[define make-root-area-container
[define/override make-root-area-container
(lambda (% parent)
(let* ([s-root (super make-root-area-container
horizontal-panel%
@ -1949,20 +1938,15 @@
(mixin (standard-menus<%>) (searchable<%>)
(init-find/replace-edits)
(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?
edit-menu:replace-and-find-again-callback edit-menu:replace-and-find-again-on-demand
edit-menu:create-replace-and-find-again?)
(define edit-menu:find-callback (lambda (menu evt) (move-to-search-or-search) #t))
(define edit-menu:create-find? (lambda () #t))
(define edit-menu:find-again-callback (lambda (menu evt) (search-again) #t))
(define edit-menu:create-find-again? (lambda () #t))
(define edit-menu:replace-and-find-again-callback (lambda (menu evt) (replace&search) #t))
(define edit-menu:replace-and-find-again-on-demand
(define/override edit-menu:find-callback (lambda (menu evt) (move-to-search-or-search) #t))
(define/override edit-menu:create-find? (lambda () #t))
(define/override edit-menu:find-again-callback (lambda (menu evt) (search-again) #t))
(define/override edit-menu:create-find-again? (lambda () #t))
(define/override edit-menu:replace-and-find-again-callback (lambda (menu evt) (replace&search) #t))
(define/override edit-menu:replace-and-find-again-on-demand
(lambda (item) (send item enable (can-replace?))))
(define edit-menu:create-replace-and-find-again? (lambda () #t))
(override make-root-area-container)
(define make-root-area-container
(define/override edit-menu:create-replace-and-find-again? (lambda () #t))
(define/override make-root-area-container
(lambda (% parent)
(let* ([s-root (super make-root-area-container
vertical-panel%
@ -2272,12 +2256,10 @@
(define searchable-text-mixin
(mixin (text<%> searchable<%>) (searchable-text<%>)
(inherit get-editor)
(override get-text-to-search)
(define (get-text-to-search)
(define/override (get-text-to-search)
(get-editor))
(override get-editor<%> get-editor%)
(define (get-editor<%>) text:searching<%>)
(define (get-editor%) text:searching%)
(define/override (get-editor<%>) text:searching<%>)
(define/override (get-editor%) text:searching%)
(super-instantiate ())))
(define memory-text% (class text% (super-new)))

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

@ -76,8 +76,7 @@
[define function-table (make-hash-table)]
(public get-function-table)
[define get-function-table (lambda () function-table)]
(override map-function)
[define map-function
[define/override map-function
(lambda (keyname fname)
(super map-function (canonicalize-keybinding-string keyname) fname)
(hash-table-put! function-table (string->symbol keyname) fname))]

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

@ -96,8 +96,7 @@
(define single-window-mixin
(mixin (single<%> window<%>) (single-window<%>)
(inherit get-client-size get-size)
(override container-size)
[define container-size
[define/override container-size
(lambda (l)
(let-values ([(super-width super-height) (super container-size l)]
[(client-width client-height) (get-client-size)]
@ -109,7 +108,7 @@
(values
(calc-size super-width client-width window-width)
(calc-size super-height client-height window-height))))]
(super-instantiate ())))
(super-new)))
(define multi-view<%>
(interface (area-container<%>)

24
collects/framework/private/text.ss
View File

@ -249,8 +249,7 @@ WARNING: printf is rebound in the body of the unit to always
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles)
(invalidate-rectangles old-rectangles))))))
(override on-paint)
(define (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(recompute-range-rectangles)
(let ([b1 (box 0)]
@ -396,8 +395,7 @@ WARNING: printf is rebound in the body of the unit to always
(define searching<%> (interface (editor:keymap<%> basic<%>)))
(define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>)
(override get-keymaps)
(define (get-keymaps)
(define/override (get-keymaps)
(cons (keymap:get-search) (super get-keymaps)))
(super-instantiate ())))
@ -405,8 +403,7 @@ WARNING: printf is rebound in the body of the unit to always
(define return-mixin
(mixin ((class->interface text%)) (return<%>)
(init-field return)
(override on-local-char)
(define (on-local-char key)
(define/override (on-local-char key)
(let ([cr-code #\return]
[lf-code #\newline]
[code (send key get-key-code)])
@ -738,20 +735,17 @@ WARNING: printf is rebound in the body of the unit to always
(when (is-a? frame frame:text-info<%>)
(call-method frame))))))
(override set-anchor set-overwrite-mode)
(augment after-set-position after-insert after-delete)
(define (set-anchor x)
(define/override (set-anchor x)
(super set-anchor x)
(enqueue-for-frame
(lambda (x) (send x anchor-status-changed))
'framework:anchor-status-changed))
(define (set-overwrite-mode x)
(define/override (set-overwrite-mode x)
(super set-overwrite-mode x)
(enqueue-for-frame
(lambda (x) (send x overwrite-status-changed))
'framework:overwrite-status-changed))
(define (after-set-position)
(define/augment (after-set-position)
(maybe-queue-editor-position-update)
(inner (void) after-set-position))
@ -771,13 +765,13 @@ WARNING: printf is rebound in the body of the unit to always
#f)))
'framework:info-frame:update-editor-position))
(define (after-insert start len)
(define/augment (after-insert start len)
(maybe-queue-editor-position-update)
(inner (void) after-insert start len))
(define (after-delete start len)
(define/augment (after-delete start len)
(maybe-queue-editor-position-update)
(inner (void) after-delete start len))
(super-instantiate ())))
(super-new)))
(define clever-file-format<%> (interface ((class->interface text%))))