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

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

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

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

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