diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss index ab53aa3b..49110562 100644 --- a/collects/framework/private/canvas.ss +++ b/collects/framework/private/canvas.ss @@ -15,81 +15,78 @@ (define basic<%> (interface ((class->interface editor-canvas%)))) (define basic-mixin - (mixin ((class->interface editor-canvas%)) (basic<%>) args - (sequence - (apply super-init args)))) + (mixin ((class->interface editor-canvas%)) (basic<%>) + (super-instantiate ()))) (define info<%> (interface (basic<%>))) ;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>))) (define info-mixin - (mixin (basic<%>) (info<%>) (parent [editor #f] . args) + (mixin (basic<%>) (info<%>) (inherit has-focus? get-top-level-window) (rename [super-on-focus on-focus] [super-set-editor set-editor]) - (override - [on-focus + (override on-focus) + [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)))] - [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))))]) - (sequence - (apply super-init parent editor args) + [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))))] - (unless (is-a? (get-top-level-window) frame:info<%>) - (error 'canvas:text-info-mixin - "expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e" - (get-top-level-window))) + (super-instantiate ()) - (when (has-focus?) - (send (get-top-level-window) update-info))))) + (unless (is-a? (get-top-level-window) frame:info<%>) + (error 'canvas:text-info-mixin + "expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e" + (get-top-level-window))) + + (when (has-focus?) + (send (get-top-level-window) update-info)))) (define wide-snip<%> (interface (basic<%>) recalc-snips add-wide-snip add-tall-snip)) - ;; wx: this need to collude with + ;; wx: this needs to collude with ;; the edit, since the edit has the right callbacks. (define wide-snip-mixin - (mixin (basic<%>) (wide-snip<%>) args + (mixin (basic<%>) (wide-snip<%>) (inherit get-editor) (rename [super-on-size on-size]) - (private-field - [wide-snips null] - [tall-snips null]) - (private - [update-snip-size - (lambda (width?) - (lambda (s) - (let* ([width (box 0)] - [height (box 0)] - [leftm (box 0)] - [rightm (box 0)] - [topm (box 0)] - [bottomm (box 0)] - [left-edge-box (box 0)] - [top-edge-box (box 0)] - [snip-media (send s get-editor)] - [edit (get-editor)] - [get-width - (let ([bl (box 0)] - [br (box 0)]) - (lambda (s) - (send edit get-snip-location s bl #f #f) - (send edit get-snip-location s br #f #t) - (- (unbox br) (unbox bl))))] - [calc-after-width - (lambda (s) - (+ 4 ;; this is compensate for an autowrapping bug - (let loop ([s s]) - (cond + [define wide-snips null] + [define tall-snips null] + [define update-snip-size + (lambda (width?) + (lambda (s) + (let* ([width (box 0)] + [height (box 0)] + [leftm (box 0)] + [rightm (box 0)] + [topm (box 0)] + [bottomm (box 0)] + [left-edge-box (box 0)] + [top-edge-box (box 0)] + [snip-media (send s get-editor)] + [edit (get-editor)] + [get-width + (let ([bl (box 0)] + [br (box 0)]) + (lambda (s) + (send edit get-snip-location s bl #f #f) + (send edit get-snip-location s br #f #t) + (- (unbox br) (unbox bl))))] + [calc-after-width + (lambda (s) + (+ 4 ;; this is compensate for an autowrapping bug + (let loop ([s s]) + (cond [(not s) 0] [(member 'hard-newline (send s get-flags)) 0] [(member 'newline (send s get-flags)) 0] @@ -99,78 +96,76 @@ 2 ;; for the caret (loop (send s next))) 0)]))))]) - (when edit - (send edit - run-after-edit-sequence - (lambda () - (let ([admin (send edit get-admin)]) - (send admin get-view #f #f width height) - (send s get-margin leftm topm rightm bottomm) - - + (when edit + (send edit + run-after-edit-sequence + (lambda () + (let ([admin (send edit get-admin)]) + (send admin get-view #f #f width height) + (send s get-margin leftm topm rightm bottomm) + + ;; when the width is to be maximized and there is a ;; newline just behind the snip, we know that the left ;; edge is zero. Special case for efficiency in the ;; console printer - (let ([fallback - (lambda () - (send edit get-snip-location - s left-edge-box top-edge-box))]) - (cond + (let ([fallback + (lambda () + (send edit get-snip-location + s left-edge-box top-edge-box))]) + (cond [(not width?) (fallback)] [(let ([prev (send s previous)]) (and prev (member 'hard-newline (send prev get-flags)))) (set-box! left-edge-box 0)] [else (fallback)])) - - (if width? - (let* ([after-width (calc-after-width (send s next))] - [snip-width (max 0 (- (unbox width) - (unbox left-edge-box) - (unbox leftm) - (unbox rightm) - after-width + + (if width? + (let* ([after-width (calc-after-width (send s next))] + [snip-width (max 0 (- (unbox width) + (unbox left-edge-box) + (unbox leftm) + (unbox rightm) + after-width ;; this two is the space that ;; the caret needs at the right of ;; a buffer. - 2))]) - (send* s - (set-min-width snip-width) - (set-max-width snip-width)) - (when snip-media - (send snip-media set-max-width - (if (send snip-media auto-wrap) - snip-width - 0)))) - (let ([snip-height (max 0 (- (unbox height) - (unbox top-edge-box) - (unbox topm) - (unbox bottomm)))]) - (send* s - (set-min-height snip-height) - (set-max-height snip-height)))))))))))]) - (public - [recalc-snips - (lambda () - (for-each (update-snip-size #t) wide-snips) - (for-each (update-snip-size #f) tall-snips))]) - (public - [add-wide-snip - (lambda (snip) - (set! wide-snips (cons snip wide-snips)) - ((update-snip-size #t) snip))] - [add-tall-snip - (lambda (snip) - (set! tall-snips (cons snip tall-snips)) - ((update-snip-size #f) snip))]) - (override - [on-size + 2))]) + (send* s + (set-min-width snip-width) + (set-max-width snip-width)) + (when snip-media + (send snip-media set-max-width + (if (send snip-media auto-wrap) + snip-width + 0)))) + (let ([snip-height (max 0 (- (unbox height) + (unbox top-edge-box) + (unbox topm) + (unbox bottomm)))]) + (send* s + (set-min-height snip-height) + (set-max-height snip-height)))))))))))] + (public recalc-snips add-wide-snip add-tall-snip) + [define recalc-snips + (lambda () + (for-each (update-snip-size #t) wide-snips) + (for-each (update-snip-size #f) tall-snips))] + [define add-wide-snip + (lambda (snip) + (set! wide-snips (cons snip wide-snips)) + ((update-snip-size #t) snip))] + [define add-tall-snip + (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))]) - (sequence - (apply super-init args)))) + (super-on-size width height))] + (super-instantiate ()))) (define basic% (basic-mixin editor-canvas%)) (define info% (info-mixin basic%)) diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 860f1881..e7d7ed15 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -38,15 +38,15 @@ save-file-out-of-date?)) (define basic-mixin - (mixin (editor<%>) (basic<%>) args + (mixin (editor<%>) (basic<%>) (inherit get-filename save-file refresh-delayed? get-canvas get-max-width get-admin) - + (rename [super-can-save-file? can-save-file?]) - (override - [can-save-file? + (override can-save-file?) + [define can-save-file? (lambda (filename format) (and (if (equal? filename (get-filename)) (if (save-file-out-of-date?) @@ -59,14 +59,13 @@ (get-top-level-focus-window)) #t) #t) - (super-can-save-file? filename format)))]) + (super-can-save-file? filename format)))] (rename [super-after-save-file after-save-file] [super-after-load-file after-load-file]) - (private-field - [last-saved-file-time #f]) - (override - [after-save-file + [define last-saved-file-time #f] + (override after-save-file after-load-file) + [define after-save-file (lambda (sucess?) (when sucess? (let ([filename (get-filename)]) @@ -75,7 +74,7 @@ (file-exists? filename) (file-or-directory-modify-seconds filename))))) (super-after-save-file sucess?))] - [after-load-file + [define after-load-file (lambda (sucess?) (when sucess? (let ([filename (get-filename)]) @@ -83,55 +82,36 @@ (and filename (file-exists? filename) (file-or-directory-modify-seconds filename))))) - (super-after-load-file sucess?))]) - (public - [save-file-out-of-date? - (lambda () - (and - last-saved-file-time - (let ([fn (get-filename)]) - (and fn - (file-exists? fn) - (let ([ms (file-or-directory-modify-seconds fn)]) - (< last-saved-file-time ms))))))]) - - (private-field - [has-focus #f]) + (super-after-load-file sucess?))] + (public save-file-out-of-date?) + [define save-file-out-of-date? + (lambda () + (and + last-saved-file-time + (let ([fn (get-filename)]) + (and fn + (file-exists? fn) + (let ([ms (file-or-directory-modify-seconds fn)]) + (< last-saved-file-time ms))))))] + + [define has-focus #f] (rename [super-on-focus on-focus]) - (override - [on-focus + (override on-focus) + [define on-focus (lambda (x) - (set! has-focus x))]) - (public - [has-focus? - (lambda () - has-focus)]) + (set! has-focus x))] + (public has-focus?) + [define has-focus? + (lambda () + has-focus)] - (rename [super-begin-edit-sequence begin-edit-sequence] - [super-end-edit-sequence end-edit-sequence]) - (private-field - [edit-sequence-count 0]) - (override - [begin-edit-sequence - (case-lambda - [() (begin-edit-sequence #t)] - [(undoable?) - (set! edit-sequence-count (+ edit-sequence-count 1)) - (super-begin-edit-sequence undoable?)])] - [end-edit-sequence - (lambda () - (set! edit-sequence-count (- edit-sequence-count 1)) - (when (< edit-sequence-count 0) - (error 'end-edit-sequence "extra end-edit-sequence")) - (super-end-edit-sequence))]) - - (public - [on-close (lambda () (void))] - [get-top-level-window - (lambda () - (let loop ([text this]) - (let ([editor-admin (send text get-admin)]) - (cond + (public on-close get-top-level-window) + [define on-close (lambda () (void))] + [define get-top-level-window + (lambda () + (let loop ([text this]) + (let ([editor-admin (send text get-admin)]) + (cond [(is-a? editor-admin editor-snip-editor-admin<%>) (let* ([snip (send editor-admin get-snip)] [snip-admin (send snip get-admin)]) @@ -139,39 +119,37 @@ [(send text get-canvas) => (lambda (canvas) (send canvas get-top-level-window))] [else - #f]))))]) - - (public [editing-this-file? (lambda () #f)]) - - (private-field - [edit-sequence-queue null] - [edit-sequence-ht (make-hash-table)]) - - (private-field - [in-local-edit-sequence? #f]) - (public - [local-edit-sequence? (lambda () in-local-edit-sequence?)] - [run-after-edit-sequence - (case-lambda - [(t) (run-after-edit-sequence t #f)] - [(t sym) - (unless (and (procedure? t) - (= 0 (procedure-arity t))) - (error 'media-buffer::run-after-edit-sequence - "expected procedure of arity zero, got: ~s~n" t)) - (unless (or (symbol? sym) (not sym)) - (error 'media-buffer::run-after-edit-sequence - "expected second argument to be a symbol, got: ~s~n" - sym)) - (if (refresh-delayed?) - (if in-local-edit-sequence? - (cond + #f]))))] + + (public editing-this-file?) + [define editing-this-file? (lambda () #f)] + + [define edit-sequence-queue null] + [define edit-sequence-ht (make-hash-table)] + [define in-local-edit-sequence? #f] + (public local-edit-sequence? run-after-edit-sequence extend-edit-sequence-queue) + [define local-edit-sequence? (lambda () in-local-edit-sequence?)] + [define run-after-edit-sequence + (case-lambda + [(t) (run-after-edit-sequence t #f)] + [(t sym) + (unless (and (procedure? t) + (= 0 (procedure-arity t))) + (error 'editor:basic::run-after-edit-sequence + "expected procedure of arity zero, got: ~s~n" t)) + (unless (or (symbol? sym) (not sym)) + (error 'editor:basic::run-after-edit-sequence + "expected second argument to be a symbol or #f, got: ~s~n" + sym)) + (if (refresh-delayed?) + (if in-local-edit-sequence? + (cond [(symbol? sym) (hash-table-put! edit-sequence-ht sym t)] [else (set! edit-sequence-queue (cons t edit-sequence-queue))]) - (let ([snip-admin (get-admin)]) - (cond + (let ([snip-admin (get-admin)]) + (cond [(not snip-admin) (t)] ;; refresh-delayed? is always #t when there is no admin. [(is-a? snip-admin editor-snip-editor-admin<%>) @@ -182,113 +160,109 @@ (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>" snip-admin)) '(t)]))) - (t)) - (void)])] - [extend-edit-sequence-queue - (lambda (l ht) - (hash-table-for-each ht (lambda (k t) - (hash-table-put! - edit-sequence-ht - k t))) - (set! edit-sequence-queue (append l edit-sequence-queue)))]) + (t)) + (void)])] + [define extend-edit-sequence-queue + (lambda (l ht) + (hash-table-for-each ht (lambda (k t) + (hash-table-put! + 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]) - (override - [on-edit-sequence + (override on-edit-sequence after-edit-sequence) + [define on-edit-sequence (lambda () (super-on-edit-sequence) (set! in-local-edit-sequence? #t))] - [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-edit - (lambda (edit) - (let ([admin (send edit get-admin)]) - (cond - [(is-a? admin editor-snip-editor-admin<%>) - (send (send (send admin get-snip) get-admin) get-editor)] - [else #f])))]) - (set! edit-sequence-queue null) - (set! edit-sequence-ht (make-hash-table)) - (let loop ([edit (find-enclosing-edit this)]) - (cond - [(and edit (not (send edit local-edit-sequence?))) - (loop (find-enclosing-edit edit))] - [edit (send edit extend-edit-sequence-queue queue ht)] - [else - (hash-table-for-each ht (lambda (k t) (t))) - (for-each (lambda (t) (t)) queue)]))))]) + [define 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-edit + (lambda (edit) + (let ([admin (send edit get-admin)]) + (cond + [(is-a? admin editor-snip-editor-admin<%>) + (send (send (send admin get-snip) get-admin) get-editor)] + [else #f])))]) + (set! edit-sequence-queue null) + (set! edit-sequence-ht (make-hash-table)) + (let loop ([edit (find-enclosing-edit this)]) + (cond + [(and edit (not (send edit local-edit-sequence?))) + (loop (find-enclosing-edit edit))] + [edit (send edit extend-edit-sequence-queue queue ht)] + [else + (hash-table-for-each ht (lambda (k t) (t))) + (for-each (lambda (t) (t)) queue)]))))] - (override - [on-new-box + (override on-new-box) + [define on-new-box (lambda (type) (cond - [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] - [else (make-object editor-snip% (make-object pasteboard:basic%))]))]) - - - (override - [get-file (lambda (d) - (parameterize ([finder:dialog-parent-parameter - (get-top-level-window)]) - (finder:get-file d)))] - [put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter - (get-top-level-window)]) - (finder:put-file f d)))]) + [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] + [else (make-object editor-snip% (make-object pasteboard:basic%))]))] + + + (override get-file put-file) + [define get-file (lambda (d) + (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:get-file d)))] + [define put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:put-file f d)))] - - (sequence - (apply super-init args)))) + + (super-instantiate ()))) - (define -keymap<%> (interface (basic<%>) get-keymaps)) (define keymap-mixin - (mixin (basic<%>) (-keymap<%>) args - (public - [get-keymaps - (lambda () - (list (keymap:get-global)))]) + (mixin (basic<%>) (-keymap<%>) + (public get-keymaps) + [define get-keymaps + (lambda () + (list (keymap:get-global)))] (inherit set-keymap) - (sequence - (apply super-init args) - (let ([keymap (make-object keymap:aug-keymap%)]) - (set-keymap keymap) - (for-each (lambda (k) (send keymap chain-to-keymap k #f)) - (get-keymaps)))))) + + (super-instantiate ()) + (let ([keymap (make-object keymap:aug-keymap%)]) + (set-keymap keymap) + (for-each (lambda (k) (send keymap chain-to-keymap k #f)) + (get-keymaps))))) (define autowrap<%> (interface (basic<%>))) (define autowrap-mixin - (mixin (basic<%>) (autowrap<%>) args + (mixin (basic<%>) (autowrap<%>) (rename [super-on-close on-close]) - (override - [on-close + (override on-close) + [define on-close (lambda () (remove-callback) - (super-on-close))]) + (super-on-close))] (inherit auto-wrap) - (sequence - (apply super-init args) - (auto-wrap - (preferences:get - 'framework:auto-set-wrap?))) - (private-field - [remove-callback - (preferences:add-callback - 'framework:auto-set-wrap? - (let ([autowrap-mixin-pref-callback - (lambda (p v) - (auto-wrap v))]) - autowrap-mixin-pref-callback))]))) + (super-instantiate ()) + (auto-wrap + (preferences:get + 'framework:auto-set-wrap?)) + [define remove-callback + (preferences:add-callback + 'framework:auto-set-wrap? + (let ([autowrap-mixin-pref-callback + (lambda (p v) + (auto-wrap v))]) + autowrap-mixin-pref-callback))])) (define file<%> (interface (-keymap<%>))) (define file-mixin - (mixin (-keymap<%>) (file<%>) args + (mixin (-keymap<%>) (file<%>) (inherit get-filename lock get-style-list is-modified? change-style set-modified get-top-level-window) @@ -297,45 +271,44 @@ [super-get-keymaps get-keymaps] [super-set-filename set-filename]) - (override - [editing-this-file? (lambda () #t)]) + (override editing-this-file?) + [define editing-this-file? (lambda () #t)] (inherit get-canvases) - (private - [check-lock - (lambda () - (let* ([filename (get-filename)] - [lock? (and filename - (file-exists? filename) - (not (member - 'write - (file-or-directory-permissions - filename))))]) - (lock lock?)))] - [update-filename - (lambda (name) - (let ([filename (if name - (file-name-from-path (normalize-path name)) - "")]) - (for-each (lambda (canvas) - (let ([tlw (send canvas get-top-level-window)]) - (when (is-a? tlw frame:editor<%>) - (send tlw set-label filename)))) - (get-canvases))))]) - (override - [after-save-file + [define check-lock + (lambda () + (let* ([filename (get-filename)] + [lock? (and filename + (file-exists? filename) + (not (member + 'write + (file-or-directory-permissions + filename))))]) + (lock lock?)))] + [define update-filename + (lambda (name) + (let ([filename (if name + (file-name-from-path (normalize-path name)) + "")]) + (for-each (lambda (canvas) + (let ([tlw (send canvas get-top-level-window)]) + (when (is-a? tlw frame:editor<%>) + (send tlw set-label filename)))) + (get-canvases))))] + (override after-save-file after-load-file set-filename get-keymaps) + [define after-save-file (lambda (success) (when success (check-lock)) (super-after-save-file success))] - [after-load-file - (lambda (sucessful?) - (when sucessful? - (check-lock)) - (super-after-load-file sucessful?))] + [define after-load-file + (lambda (sucessful?) + (when sucessful? + (check-lock)) + (super-after-load-file sucessful?))] - [set-filename + [define set-filename (case-lambda [(name) (set-filename name #f)] [(name temp?) @@ -343,11 +316,10 @@ (unless temp? (update-filename name))])] - [get-keymaps + [define get-keymaps (lambda () - (cons (keymap:get-file) (super-get-keymaps)))]) - (sequence - (apply super-init args)))) + (cons (keymap:get-file) (super-get-keymaps)))] + (super-instantiate ()))) (define backup-autosave<%> (interface (basic<%>) @@ -356,31 +328,29 @@ do-autosave remove-autosave)) - ; what about checking the autosave files when a file is opened? + ; what about checking the autosave files when a file is opened? (define backup-autosave-mixin - (mixin (basic<%>) (backup-autosave<%>) args + (mixin (basic<%>) (backup-autosave<%>) (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]) - (private-field - [auto-saved-name #f] - [auto-save-out-of-date? #t] - [auto-save-error? #f]) - (private - [file-old? - (lambda (filename) - (if (and filename - (file-exists? filename)) - (let ([modified-seconds (file-or-directory-modify-seconds filename)] - [old-seconds (- (current-seconds) (* 7 24 60 60))]) - (< modified-seconds old-seconds)) - #t))]) - (public - [backup? (lambda () #t)]) - (override - [on-save-file + [define auto-saved-name #f] + [define auto-save-out-of-date? #t] + [define auto-save-error? #f] + [define file-old? + (lambda (filename) + (if (and filename + (file-exists? filename)) + (let ([modified-seconds (file-or-directory-modify-seconds filename)] + [old-seconds (- (current-seconds) (* 7 24 60 60))]) + (< modified-seconds old-seconds)) + #t))] + (public backup?) + [define backup? (lambda () #t)] + (override on-save-file on-close on-change set-modified) + [define on-save-file (lambda (name format) (super-on-save-file name format) (set! auto-save-error? #f) @@ -394,75 +364,73 @@ (delete-file back-name)) (with-handlers ([(lambda (x) #t) void]) (copy-file name back-name))))))] - [on-close - (lambda () - (super-on-close) - (remove-autosave) - (set! do-autosave? #f))] - [on-change + [define on-close + (lambda () + (super-on-close) + (remove-autosave) + (set! do-autosave? #f))] + [define on-change (lambda () (super-on-change) (set! auto-save-out-of-date? #t))] - [set-modified + [define set-modified (lambda (modified?) (when auto-saved-name (if modified? (set! auto-save-out-of-date? #t) (remove-autosave))) - (super-set-modified modified?))]) - (private-field - [do-autosave? #t]) - (public - [autosave? (lambda () do-autosave?)] - [do-autosave - (lambda () - (when (and (autosave?) - (not auto-save-error?) - (is-modified?) - (or (not auto-saved-name) - auto-save-out-of-date?)) - (let* ([orig-name (get-filename)] - [old-auto-name auto-saved-name] - [auto-name (path-utils:generate-autosave-name orig-name)] - [success (save-file auto-name 'copy)]) - (if success - (begin - (when old-auto-name - (delete-file old-auto-name)) - (set! auto-saved-name auto-name) - (set! auto-save-out-of-date? #f)) - (begin - (message-box - "Warning" - (format "Error autosaving ~s.~n~a~n~a" - (or orig-name "Untitled") - "Autosaving is turned off" - "until the file is saved.")) - (set! auto-save-error? #t))))))] - [remove-autosave - (lambda () - (when auto-saved-name - (when (file-exists? auto-saved-name) - (delete-file auto-saved-name)) - (set! auto-saved-name #f)))]) - (sequence - (apply super-init args) - (autosave:register this)))) + (super-set-modified modified?))] + [define do-autosave? #t] + (public autosave? do-autosave remove-autosave) + [define autosave? (lambda () do-autosave?)] + [define do-autosave + (lambda () + (when (and (autosave?) + (not auto-save-error?) + (is-modified?) + (or (not auto-saved-name) + auto-save-out-of-date?)) + (let* ([orig-name (get-filename)] + [old-auto-name auto-saved-name] + [auto-name (path-utils:generate-autosave-name orig-name)] + [success (save-file auto-name 'copy)]) + (if success + (begin + (when old-auto-name + (delete-file old-auto-name)) + (set! auto-saved-name auto-name) + (set! auto-save-out-of-date? #f)) + (begin + (message-box + "Warning" + (format "Error autosaving ~s.~n~a~n~a" + (or orig-name "Untitled") + "Autosaving is turned off" + "until the file is saved.")) + (set! auto-save-error? #t))))))] + [define remove-autosave + (lambda () + (when auto-saved-name + (when (file-exists? auto-saved-name) + (delete-file auto-saved-name)) + (set! auto-saved-name #f)))] + (super-instantiate ()) + (autosave:register this))) (define info<%> (interface (basic<%>))) (define info-mixin - (mixin (basic<%>) (info<%>) args + (mixin (basic<%>) (info<%>) (inherit get-top-level-window run-after-edit-sequence) (rename [super-lock lock]) - (override - [lock + (override lock) + [define lock (lambda (x) (super-lock x) (run-after-edit-sequence (rec send-frame-update-lock-icon - (lambda () - (let ([frame (get-top-level-window)]) - (when (is-a? frame frame:info<%>) - (send frame lock-status-changed))))) - 'framework:update-lock-icon))]) - (sequence (apply super-init args))))))) + (lambda () + (let ([frame (get-top-level-window)]) + (when (is-a? frame frame:info<%>) + (send frame lock-status-changed))))) + 'framework:update-lock-icon))] + (super-instantiate ())))))) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index b18815ac..625fb8c2 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1,3 +1,4 @@ + (module frame mzscheme (require (lib "unitsig.ss") (lib "class.ss") @@ -80,88 +81,75 @@ get-filename)) (define basic-mixin (mixin ((class->interface frame%)) (basic<%>) - (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) (rename [super-can-close? can-close?] [super-on-close on-close] [super-on-focus on-focus]) - (public - [get-filename + (public get-filename) + [define get-filename (case-lambda [() (get-filename #f)] - [(b) #f])]) - (private-field - [after-init? #f]) - (override - [can-close? - (lambda () - (let ([super (super-can-close?)] - [group - (send (group:get-the-frame-group) - can-remove-frame? - this)]) - (and super group)))] - [on-close - (lambda () - (super-on-close) - (send (group:get-the-frame-group) - remove-frame - this))] - [on-focus - (lambda (on?) - (super-on-focus on?) - (when on? - (send (group:get-the-frame-group) set-active-frame this)))] - - [on-drop-file - (lambda (filename) - (handler:edit-file filename))]) + [(b) #f])] + (define after-init? #f) + (override can-close? on-close on-focus on-drop-file) + [define can-close? + (lambda () + (let ([super (super-can-close?)] + [group + (send (group:get-the-frame-group) + can-remove-frame? + this)]) + (and super group)))] + [define on-close + (lambda () + (super-on-close) + (send (group:get-the-frame-group) + remove-frame + this))] + [define on-focus + (lambda (on?) + (super-on-focus on?) + (when on? + (send (group:get-the-frame-group) set-active-frame this)))] + + [define on-drop-file + (lambda (filename) + (handler:edit-file filename))] ;; added call to set label here to hopefully work around a problem in mac mred (inherit set-label change-children) - (override - [after-new-child - (lambda (child) - (when after-init? - (change-children (lambda (l) (remq child l))) - (error 'frame:basic-mixin - "do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead" - )))]) + (override after-new-child) + [define after-new-child + (lambda (child) + (when after-init? + (change-children (lambda (l) (remq child l))) + (error 'frame:basic-mixin + "do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead" + )))] (inherit show) - (public - [get-area-container% (lambda () vertical-panel%)] - [get-menu-bar% (lambda () menu-bar%)] - [make-root-area-container - (lambda (% parent) - (make-object % parent))] - [close - (lambda () - (when (can-close?) - (on-close) - (show #f)))]) + (public get-area-container% get-menu-bar% make-root-area-container close) + [define get-area-container% (lambda () vertical-panel%)] + [define get-menu-bar% (lambda () menu-bar%)] + [define make-root-area-container + (lambda (% parent) + (make-object % parent))] + [define close + (lambda () + (when (can-close?) + (on-close) + (show #f)))] (inherit accept-drop-files) - (sequence - (let ([mdi-parent (send (group:get-the-frame-group) get-mdi-parent)]) - (super-init label - (or parent mdi-parent) - width height x y - (cond - [parent style] - [mdi-parent (cons 'mdi-child style)] - [else style]))) + (super-instantiate ()) + (accept-drop-files #t) - (accept-drop-files #t) - - (make-object menu% "&Window" (make-object (get-menu-bar%) this)) - (reorder-menus this) - (send (group:get-the-frame-group) insert-frame this)) - (private-field - [panel (make-root-area-container (get-area-container%) this)]) - (public - [get-area-container (lambda () panel)]) - (sequence - (set! after-init? #t)))) + (make-object menu% "&Window" (make-object (get-menu-bar%) this)) + (reorder-menus this) + (send (group:get-the-frame-group) insert-frame this) + [define panel (make-root-area-container (get-area-container%) this)] + (public get-area-container) + [define get-area-container (lambda () panel)] + (set! after-init? #t))) (define locked-message "Read only") (define unlocked-message "Read/Write") @@ -217,195 +205,183 @@ (define magic-space 25) (define info-mixin - (mixin (basic<%>) (info<%>) args + (mixin (basic<%>) (info<%>) (rename [super-make-root-area-container make-root-area-container]) - (private-field - [rest-panel 'uninitialized-root] - [super-root 'uninitialized-super-root]) - (override - [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 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))] - (private-field - [info-canvas #f]) - (public - [get-info-canvas - (lambda () - info-canvas)] - [set-info-canvas - (lambda (c) - (set! info-canvas c))] - [get-info-editor - (lambda () - (and info-canvas - (send info-canvas get-editor)))]) + [define info-canvas #f] + (public get-info-canvas set-info-canvas get-info-editor) + [define get-info-canvas + (lambda () + info-canvas)] + [define set-info-canvas + (lambda (c) + (set! info-canvas c))] + [define get-info-editor + (lambda () + (and info-canvas + (send info-canvas get-editor)))] - (public - [determine-width - (lambda (string canvas edit) - (send edit set-autowrap-bitmap #f) - (send canvas call-as-primary-owner - (lambda () - (let ([lb (box 0)] - [rb (box 0)]) - (send edit erase) - (send edit insert string) - (send edit position-location - (send edit last-position) - rb) - (send edit position-location 0 lb) - (send canvas min-width - (+ magic-space (- (inexact->exact (floor (unbox rb))) - (inexact->exact (floor (unbox lb))))))))))]) + (public determine-width) + [define determine-width + (lambda (string canvas edit) + (send edit set-autowrap-bitmap #f) + (send canvas call-as-primary-owner + (lambda () + (let ([lb (box 0)] + [rb (box 0)]) + (send edit erase) + (send edit insert string) + (send edit position-location + (send edit last-position) + rb) + (send edit position-location 0 lb) + (send canvas min-width + (+ magic-space (- (inexact->exact (floor (unbox rb))) + (inexact->exact (floor (unbox lb))))))))))] (rename [super-on-close on-close]) - (private-field - [outer-info-panel 'top-info-panel-uninitialized] - [close-panel-callback - (preferences:add-callback - 'framework:show-status-line - (lambda (p v) - (if v - (register-gc-blit) - (unregister-collecting-blit gc-canvas)) - (send super-root change-children - (lambda (l) - (if v - (list rest-panel outer-info-panel) - (list rest-panel))))))]) - (private-field - [memory-cleanup void]) ;; only for CVSers; used with memory-text - (override - [on-close - (lambda () - (super-on-close) - (unregister-collecting-blit gc-canvas) - (close-panel-callback) - (memory-cleanup))]) + [define outer-info-panel 'top-info-panel-uninitialized] + [define close-panel-callback + (preferences:add-callback + 'framework:show-status-line + (lambda (p v) + (if v + (register-gc-blit) + (unregister-collecting-blit gc-canvas)) + (send super-root change-children + (lambda (l) + (if v + (list rest-panel outer-info-panel) + (list rest-panel))))))] + [define memory-cleanup void] ;; only for CVSers; used with memory-text + (override on-close) + [define on-close + (lambda () + (super-on-close) + (unregister-collecting-blit gc-canvas) + (close-panel-callback) + (memory-cleanup))] - (private-field - [icon-currently-locked? 'uninit]) - (public - [lock-status-changed - (lambda () - (let ([info-edit (get-info-editor)]) - (cond - [(not (object? lock-canvas)) - (void)] - [info-edit - (unless (send lock-canvas is-shown?) - (send lock-canvas show #t)) - (let ([locked-now? (send info-edit is-locked?)]) - (unless (eq? locked-now? icon-currently-locked?) - (set! icon-currently-locked? locked-now?) - (when (object? lock-canvas) - (send lock-canvas set-locked locked-now?))))] - [else - (when (send lock-canvas is-shown?) - (send lock-canvas show #f))])))]) + [define icon-currently-locked? 'uninit] + (public lock-status-changed) + [define lock-status-changed + (lambda () + (let ([info-edit (get-info-editor)]) + (cond + [(not (object? lock-canvas)) + (void)] + [info-edit + (unless (send lock-canvas is-shown?) + (send lock-canvas show #t)) + (let ([locked-now? (send info-edit is-locked?)]) + (unless (eq? locked-now? icon-currently-locked?) + (set! icon-currently-locked? locked-now?) + (when (object? lock-canvas) + (send lock-canvas set-locked locked-now?))))] + [else + (when (send lock-canvas is-shown?) + (send lock-canvas show #f))])))] - (public - [update-info - (lambda () - (lock-status-changed))]) + (public update-info) + [define update-info + (lambda () + (lock-status-changed))] - (sequence - (apply super-init args) - (set! outer-info-panel (make-object horizontal-panel% super-root)) - (send outer-info-panel stretchable-height #f)) + (super-instantiate ()) + (set! outer-info-panel (make-object horizontal-panel% super-root)) + (send outer-info-panel stretchable-height #f) - (private-field - [info-panel (make-object horizontal-panel% outer-info-panel)]) - (sequence - (make-object grow-box-spacer-pane% outer-info-panel)) - (public - [get-info-panel - (lambda () - info-panel)]) - (public - [update-memory-text - (lambda () - (when show-memory-text? - (send memory-text begin-edit-sequence) - (send memory-text lock #f) - (send memory-text erase) - (send memory-text insert (number->string (current-memory-use))) - (send memory-text lock #t) - (send memory-text end-edit-sequence)))]) + [define info-panel (make-object horizontal-panel% outer-info-panel)] + (make-object grow-box-spacer-pane% outer-info-panel) + (public get-info-panel) + [define get-info-panel + (lambda () + info-panel)] + (public update-memory-text) + [define update-memory-text + (lambda () + (when show-memory-text? + (send memory-text begin-edit-sequence) + (send memory-text lock #f) + (send memory-text erase) + (send memory-text insert (number->string (current-memory-use))) + (send memory-text lock #t) + (send memory-text end-edit-sequence)))] - (sequence ; only for CVSers - (when show-memory-text? - (let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))] - [button (make-object button% "Collect" panel - (lambda x - (collect-garbage) - (update-memory-text)))] - [ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))]) - (determine-width "000000000" ec memory-text) - (update-memory-text) - (set! memory-cleanup - (lambda () - (send ec set-editor #f))) - (send panel stretchable-width #f)))) - (private-field - [lock-canvas (make-object lock-canvas% (get-info-panel))] - [gc-canvas (make-object canvas% (get-info-panel) '(border))]) - (private - [register-gc-blit - (lambda () - (let ([onb (icon:get-gc-on-bitmap)] - [offb (icon:get-gc-off-bitmap)]) - (when (and (send onb ok?) - (send offb ok?)) - (register-collecting-blit gc-canvas - 0 0 - (send onb get-width) - (send onb get-height) - onb offb))))]) + (when show-memory-text? + (let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))] + [button (make-object button% "Collect" panel + (lambda x + (collect-garbage) + (update-memory-text)))] + [ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))]) + (determine-width "000000000" ec memory-text) + (update-memory-text) + (set! memory-cleanup + (lambda () + (send ec set-editor #f))) + (send panel stretchable-width #f))) + + [define lock-canvas (make-object lock-canvas% (get-info-panel))] + [define gc-canvas (make-object canvas% (get-info-panel) '(border))] + [define register-gc-blit + (lambda () + (let ([onb (icon:get-gc-on-bitmap)] + [offb (icon:get-gc-off-bitmap)]) + (when (and (send onb ok?) + (send offb ok?)) + (register-collecting-blit gc-canvas + 0 0 + (send onb get-width) + (send onb get-height) + onb offb))))] - (sequence - (unless (preferences:get 'framework:show-status-line) - (send super-root change-children - (lambda (l) - (list rest-panel)))) - (register-gc-blit) + (unless (preferences:get 'framework:show-status-line) + (send super-root change-children + (lambda (l) + (list rest-panel)))) + (register-gc-blit) - (let* ([gcb (icon:get-gc-on-bitmap)] - [gc-width (if (send gcb ok?) - (send gcb get-width) - 10)] - [gc-height (if (send gcb ok?) - (send gcb get-height) - 10)]) - (send* gc-canvas - (min-client-width (max (send gc-canvas min-width) gc-width)) - (min-client-height (max (send gc-canvas min-height) gc-height)) - (stretchable-width #f) - (stretchable-height #f))) - (send* (get-info-panel) - (set-alignment 'right 'center) - (stretchable-height #f) - (spacing 3) - (border 3))))) + (let* ([gcb (icon:get-gc-on-bitmap)] + [gc-width (if (send gcb ok?) + (send gcb get-width) + 10)] + [gc-height (if (send gcb ok?) + (send gcb get-height) + 10)]) + (send* gc-canvas + (min-client-width (max (send gc-canvas min-width) gc-width)) + (min-client-height (max (send gc-canvas min-height) gc-height)) + (stretchable-width #f) + (stretchable-height #f))) + (send* (get-info-panel) + (set-alignment 'right 'center) + (stretchable-height #f) + (spacing 3) + (border 3)))) (define text-info<%> (interface (info<%>) overwrite-status-changed anchor-status-changed editor-position-changed)) (define text-info-mixin - (mixin (info<%>) (text-info<%>) args + (mixin (info<%>) (text-info<%>) (inherit get-info-editor) (rename [super-on-close on-close]) - (private-field - [remove-first + [define remove-first (preferences:add-callback 'framework:line-offsets (lambda (p v) @@ -413,26 +389,24 @@ v (preferences:get 'framework:display-line-numbers)) #t))] - [remove-second + [define remove-second (preferences:add-callback 'framework:display-line-numbers (lambda (p v) (editor-position-changed-offset/numbers (preferences:get 'framework:line-offsets) v) - #t))]) - (override - [on-close - (lambda () - (super-on-close) - (remove-first) - (remove-second))]) - (private-field - [last-start #f] - [last-end #f] - [last-params #f]) - (private - [editor-position-changed-offset/numbers + #t))] + (override on-close) + [define on-close + (lambda () + (super-on-close) + (remove-first) + (remove-second))] + [define last-start #f] + [define last-end #f] + [define last-params #f] + [define editor-position-changed-offset/numbers (lambda (offset? line-numbers?) (let* ([edit (get-info-editor)] [make-one @@ -480,38 +454,37 @@ (lock #t)))))] [else (when (send position-canvas is-shown?) - (send position-canvas show #f))])))]) - (private-field - [anchor-last-state? #f] - [overwrite-last-state? #f]) - (public - [anchor-status-changed - (lambda () - (let ([info-edit (get-info-editor)] - [failed - (lambda () - (unless (eq? anchor-last-state? #f) - (set! anchor-last-state? #f) - (send anchor-message show #f)))]) - (cond - [info-edit - (let ([anchor-now? (send info-edit get-anchor)]) - (unless (eq? anchor-now? anchor-last-state?) - (cond - [(object? anchor-message) - (send anchor-message - show - anchor-now?) - (set! anchor-last-state? anchor-now?)] - [else (failed)])))] - [else - (failed)])))] - [editor-position-changed + (send position-canvas show #f))])))] + [define anchor-last-state? #f] + [define overwrite-last-state? #f] + (public anchor-status-changed editor-position-changed overwrite-status-changed) + [define anchor-status-changed + (lambda () + (let ([info-edit (get-info-editor)] + [failed + (lambda () + (unless (eq? anchor-last-state? #f) + (set! anchor-last-state? #f) + (send anchor-message show #f)))]) + (cond + [info-edit + (let ([anchor-now? (send info-edit get-anchor)]) + (unless (eq? anchor-now? anchor-last-state?) + (cond + [(object? anchor-message) + (send anchor-message + show + anchor-now?) + (set! anchor-last-state? anchor-now?)] + [else (failed)])))] + [else + (failed)])))] + [define editor-position-changed (lambda () (editor-position-changed-offset/numbers (preferences:get 'framework:line-offsets) (preferences:get 'framework:display-line-numbers)))] - [overwrite-status-changed + [define overwrite-status-changed (lambda () (let ([info-edit (get-info-editor)] [failed @@ -531,67 +504,63 @@ [else (failed)])))] [else - (failed)])))]) + (failed)])))] (rename [super-update-info update-info]) - (override - [update-info - (lambda () - (super-update-info) - (overwrite-status-changed) - (anchor-status-changed) - (editor-position-changed))]) - (sequence - (apply super-init args)) + (override update-info) + [define update-info + (lambda () + (super-update-info) + (overwrite-status-changed) + (anchor-status-changed) + (editor-position-changed))] + (super-instantiate ()) (inherit get-info-panel) - (private-field - [anchor-message - (make-object message% - (let ([b (icon:get-anchor-bitmap)]) - (if (and #f (send b ok?)) - b - "Auto-extend Selection")) - (get-info-panel))] - [overwrite-message - (make-object message% - "Overwrite" - (get-info-panel))] - [position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))] - [position-edit (make-object text%)]) + [define anchor-message + (make-object message% + (let ([b (icon:get-anchor-bitmap)]) + (if (and #f (send b ok?)) + b + "Auto-extend Selection")) + (get-info-panel))] + [define overwrite-message + (make-object message% + "Overwrite" + (get-info-panel))] + [define position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))] + [define position-edit (make-object text%)] (inherit determine-width) - (sequence - (let ([move-front - (lambda (x l) - (cons x (remq x l)))]) - (send (get-info-panel) change-children - (lambda (l) + (let ([move-front + (lambda (x l) + (cons x (remq x l)))]) + (send (get-info-panel) change-children + (lambda (l) + (move-front + anchor-message + (move-front + overwrite-message (move-front - anchor-message - (move-front - overwrite-message - (move-front - position-canvas - l)))))) - (send anchor-message show #f) - (send overwrite-message show #f) - (send* position-canvas - (set-line-count 1) - (set-editor position-edit) - (stretchable-width #f) - (stretchable-height #f)) - (determine-width "0000:000-0000:000" - position-canvas - position-edit) - (editor-position-changed) - (send position-edit hide-caret #t) - (send position-edit lock #t)))) + position-canvas + l)))))) + (send anchor-message show #f) + (send overwrite-message show #f) + (send* position-canvas + (set-line-count 1) + (set-editor position-edit) + (stretchable-width #f) + (stretchable-height #f)) + (determine-width "0000:000-0000:000" + position-canvas + position-edit) + (editor-position-changed) + (send position-edit hide-caret #t) + (send position-edit lock #t))) (define pasteboard-info<%> (interface (info<%>))) (define pasteboard-info-mixin - (mixin (basic<%>) (pasteboard-info<%>) args - (sequence - (apply super-init args)))) + (mixin (basic<%>) (pasteboard-info<%>) + (super-instantiate ()))) (include "standard-menus.ss") @@ -614,259 +583,243 @@ (define editor-mixin (mixin (standard-menus<%>) (-editor<%>) - (file-name - [parent #f] - [width frame-width] - [height frame-height] - . - args) + (init file-name) + (inherit get-area-container get-client-size show get-edit-target-window get-edit-target-object) (rename [super-on-close on-close] [super-set-label set-label]) - (override - [get-filename - (case-lambda - [() (get-filename #f)] - [(b) - (let ([e (get-editor)]) - (and e (send e get-filename b)))])] - [on-close - (lambda () - (super-on-close) - (send (get-editor) on-close))]) - (private-field - [label (if file-name - (file-name-from-path file-name) - (gui-utils:next-untitled-name))] - [label-prefix (application:current-app-name)]) - (private - [do-label - (lambda () - (super-set-label (get-entire-label)) - (send (group:get-the-frame-group) frame-label-changed this))]) + (override get-filename on-close) + [define get-filename + (case-lambda + [() (get-filename #f)] + [(b) + (let ([e (get-editor)]) + (and e (send e get-filename b)))])] + [define on-close + (lambda () + (super-on-close) + (send (get-editor) on-close))] + [define label (if file-name + (file-name-from-path file-name) + (gui-utils:next-untitled-name))] + [define label-prefix (application:current-app-name)] + [define do-label + (lambda () + (super-set-label (get-entire-label)) + (send (group:get-the-frame-group) frame-label-changed this))] - (public - [get-entire-label - (lambda () - (cond - [(string=? "" label) - label-prefix] - [(string=? "" label-prefix) - label] - [else - (string-append label " - " label-prefix)]))] - [get-label-prefix (lambda () label-prefix)] - [set-label-prefix - (lambda (s) - (when (and (string? s) - (not (string=? s label-prefix))) - (set! label-prefix s) - (do-label)))]) - (override - [get-label (lambda () label)] - [set-label - (lambda (t) - (when (and (string? t) - (not (string=? t label))) - (set! label t) - (do-label)))]) - (public - [get-canvas% (lambda () editor-canvas%)] - [get-canvas<%> (lambda () (class->interface editor-canvas%))] - [make-canvas (lambda () - (let ([% (get-canvas%)] - [<%> (get-canvas<%>)]) - (unless (implementation? % <%>) - (error 'frame:editor% - "result of get-canvas% method must match ~e interface; got: ~e" - <%> %)) - (make-object % (get-area-container))))] - [get-editor% (lambda () (error 'editor-frame% "no editor% class specified"))] - [get-editor<%> (lambda () editor<%>)] - [make-editor (lambda () - (let ([% (get-editor%)] - [<%> (get-editor<%>)]) - (unless (implementation? % <%>) - (error 'frame:editor% - "result of get-editor% method must match ~e interface; got: ~e" - <%> %)) - (make-object %)))]) + (public get-entire-label get-label-prefix set-label-prefix) + [define get-entire-label + (lambda () + (cond + [(string=? "" label) + label-prefix] + [(string=? "" label-prefix) + label] + [else + (string-append label " - " label-prefix)]))] + [define get-label-prefix (lambda () label-prefix)] + [define set-label-prefix + (lambda (s) + (when (and (string? s) + (not (string=? s label-prefix))) + (set! label-prefix s) + (do-label)))] + (override get-label set-label) + [define get-label (lambda () label)] + [define set-label + (lambda (t) + (when (and (string? t) + (not (string=? t label))) + (set! label t) + (do-label)))] + + (public get-canvas% get-canvas<%> make-canvas get-editor% get-editor<%> make-editor) + [define get-canvas% (lambda () editor-canvas%)] + [define get-canvas<%> (lambda () (class->interface editor-canvas%))] + [define make-canvas (lambda () + (let ([% (get-canvas%)] + [<%> (get-canvas<%>)]) + (unless (implementation? % <%>) + (error 'frame:editor% + "result of get-canvas% method must match ~e interface; got: ~e" + <%> %)) + (make-object % (get-area-container))))] + [define get-editor% (lambda () (error 'editor-frame% "no editor% class specified"))] + [define get-editor<%> (lambda () editor<%>)] + [define make-editor (lambda () + (let ([% (get-editor%)] + [<%> (get-editor<%>)]) + (unless (implementation? % <%>) + (error 'frame:editor% + "result of get-editor% method must match ~e interface; got: ~e" + <%> %)) + (make-object %)))] - (public - [save-as - (opt-lambda ([format 'same]) - (let* ([name (send (get-editor) get-filename)] - [file (parameterize ([finder:dialog-parent-parameter this]) - (finder:put-file name))]) - (when file - (send (get-editor) save-file file format))))]) + (public save-as) + [define save-as + (opt-lambda ([format 'same]) + (let* ([name (send (get-editor) get-filename)] + [file (parameterize ([finder:dialog-parent-parameter this]) + (finder:put-file name))]) + (when file + (send (get-editor) save-file file format))))] (inherit get-checkable-menu-item% get-menu-item%) - (override - [file-menu:revert-callback - (lambda (item control) - (let* ([b (box #f)] - [edit (get-editor)] - [filename (send edit get-filename b)]) - (if (or (not filename) (unbox b)) - (bell) - (let ([start - (if (is-a? edit text%) - (send edit get-start-position) - #f)]) - (send edit begin-edit-sequence) - (let ([status (send edit load-file - filename - 'same - #f)]) - (if status + (override file-menu:revert-callback file-menu:create-revert? 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 file-menu:revert-callback + (lambda (item control) + (let* ([b (box #f)] + [edit (get-editor)] + [filename (send edit get-filename b)]) + (if (or (not filename) (unbox b)) + (bell) + (let ([start + (if (is-a? edit text%) + (send edit get-start-position) + #f)]) + (send edit begin-edit-sequence) + (let ([status (send edit load-file + filename + 'same + #f)]) + (if status + (begin + (when (is-a? edit text%) + (send edit set-position start start)) + (send edit end-edit-sequence)) + (begin + (send edit end-edit-sequence) + (message-box + "Error Reverting" + (format "could not read ~a" filename))))))) + #t))] + [define file-menu:create-revert? (lambda () #t)] + [define file-menu:save-callback (lambda (item control) + (send (get-editor) save-file) + #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) + (send (get-editor) print + #t + #t + (preferences:get 'framework:print-output-mode)) + #t)] + [define file-menu:create-print? (lambda () #t)] + + [define edit-menu:do (lambda (const) + (lambda (menu evt) + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (send edit do-edit-operation const))) + #t))] + + (public add-edit-menu-snip-items) + [define add-edit-menu-snip-items + (lambda (edit-menu) + (let ([c% (get-menu-item%)] + [on-demand + (lambda (menu-item) + (let ([edit (get-edit-target-object)]) + (send menu-item enable (and edit (is-a? edit editor<%>)))))]) + + (make-object c% "Insert Text Box" edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand) + (make-object c% "Insert Pasteboard Box" edit-menu (edit-menu:do 'insert-pasteboard-box) #f #f on-demand) + (make-object c% "Insert Image..." edit-menu (edit-menu:do 'insert-image) #f #f on-demand)))] + + + (override edit-menu:between-select-all-and-find) + [define edit-menu:between-select-all-and-find + (lambda (edit-menu) + (make-object separator-menu-item% edit-menu) + + (add-edit-menu-snip-items edit-menu) + + (let* ([c% (get-checkable-menu-item%)] + [on-demand + (lambda (menu-item) + (let ([edit (get-edit-target-object)]) + (if (and edit (is-a? edit editor<%>)) (begin - (when (is-a? edit text%) - (send edit set-position start start)) - (send edit end-edit-sequence)) - (begin - (send edit end-edit-sequence) - (message-box - "Error Reverting" - (format "could not read ~a" filename))))))) - #t))] - [file-menu:create-revert? (lambda () #t)] - [file-menu:save-callback (lambda (item control) - (send (get-editor) save-file) - #t)] - [file-menu:create-save? (lambda () #t)] - [file-menu:save-as-callback (lambda (item control) (save-as) #t)] - [file-menu:create-save-as? (lambda () #t)] - [file-menu:print-callback (lambda (item control) - (send (get-editor) print - #t - #t - (preferences:get 'framework:print-output-mode)) - #t)] - [file-menu:create-print? (lambda () #t)]) + (send menu-item enable #t) + (send menu-item check (send edit auto-wrap))) + (begin + (send menu-item check #f) + (send menu-item enable #f)))))] + [callback + (lambda (item event) + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (send edit auto-wrap (not (send edit auto-wrap))))))]) + (make-object c% "Wrap Text" edit-menu callback #f #f on-demand)) + + (make-object separator-menu-item% edit-menu))] - (private - [edit-menu:do (lambda (const) - (lambda (menu evt) - (let ([edit (get-edit-target-object)]) - (when (and edit - (is-a? edit editor<%>)) - (send edit do-edit-operation const))) - #t))]) + (override help-menu:about-callback help-menu:about-string help-menu:create-about?) + [define help-menu:about-callback + (lambda (menu evt) + (message-box (application:current-app-name) + (format "Welcome to ~a" (application:current-app-name))))] + [define help-menu:about-string (lambda () (application:current-app-name))] + [define help-menu:create-about? (lambda () #t)] - (public - [add-edit-menu-snip-items - (lambda (edit-menu) - (let ([c% (class100 (get-menu-item%) args - (inherit enable) - (rename [super-on-demand on-demand]) - (override - [on-demand - (lambda () - (let ([edit (get-edit-target-object)]) - (enable (and edit (is-a? edit editor<%>)))))]) - (sequence (apply super-init args)))]) - - (make-object c% "Insert Text Box" edit-menu (edit-menu:do 'insert-text-box)) - (make-object c% "Insert Pasteboard Box" edit-menu (edit-menu:do 'insert-pasteboard-box)) - (make-object c% "Insert Image..." edit-menu (edit-menu:do 'insert-image))))]) + (super-instantiate + () + (label (get-entire-label))) - - (override - [edit-menu:between-select-all-and-find - (lambda (edit-menu) - (make-object separator-menu-item% edit-menu) - - (add-edit-menu-snip-items edit-menu) - - (let* ([c% (class100 (get-checkable-menu-item%) args - (rename [super-on-demand on-demand]) - (inherit check enable) - (override - [on-demand - (lambda () - (let ([edit (get-edit-target-object)]) - (if (and edit - (is-a? edit editor<%>)) - (begin - (enable #t) - (check (send edit auto-wrap))) - (begin - (check #f) - (enable #f)))))]) - (sequence (apply super-init args)))]) - (make-object c% "Wrap Text" edit-menu - (lambda (item event) - (let ([edit (get-edit-target-object)]) - (when (and edit - (is-a? edit editor<%>)) - (send edit auto-wrap (not (send edit auto-wrap)))))))) - - (make-object separator-menu-item% edit-menu))]) - - (override - [help-menu:about-callback - (lambda (menu evt) - (message-box (application:current-app-name) - (format "Welcome to ~a" (application:current-app-name))))] - [help-menu:about-string (lambda () (application:current-app-name))] - [help-menu:create-about? (lambda () #t)]) - - (sequence - (apply super-init - (get-entire-label) - parent - width - height - args)) - - (private-field - [canvas #f] - [editor #f]) - (public - [get-canvas - (lambda () - (unless canvas - (set! canvas (make-canvas)) - (send canvas set-editor (get-editor))) - canvas)] - [get-editor - (lambda () - (unless editor - (set! editor (make-editor)) - (send (get-canvas) set-editor editor)) - editor)]) - (sequence - (do-label) - (cond - [(and file-name (file-exists? file-name)) - (send (get-editor) load-file file-name 'guess #f)] - [file-name - (send (get-editor) set-filename file-name)] - [else (void)]) - (let ([canvas (get-canvas)]) - (when (is-a? canvas editor-canvas%) + [define canvas #f] + [define editor #f] + (public get-canvas get-editor) + [define get-canvas + (lambda () + (unless canvas + (set! canvas (make-canvas)) + (send canvas set-editor (get-editor))) + canvas)] + [define get-editor + (lambda () + (unless editor + (set! editor (make-editor)) + (send (get-canvas) set-editor editor)) + editor)] + + (do-label) + (cond + [(and file-name (file-exists? file-name)) + (send (get-editor) load-file file-name 'guess #f)] + [file-name + (send (get-editor) set-filename file-name)] + [else (void)]) + (let ([canvas (get-canvas)]) + (when (is-a? canvas editor-canvas%) ;; when get-canvas is overridden, ;; it might not yet be implemented - (send canvas focus)))))) + (send canvas focus))))) (define text<%> (interface (-editor<%>))) (define text-mixin - (mixin (-editor<%>) (text<%>) args - (override - [get-editor<%> (lambda () (class->interface text%))] - [get-editor% (lambda () text:keymap%)]) - (sequence (apply super-init args)))) + (mixin (-editor<%>) (text<%>) + (override get-editor<%> get-editor%) + [define get-editor<%> (lambda () (class->interface text%))] + [define get-editor% (lambda () text:keymap%)] + (super-instantiate ()))) (define pasteboard<%> (interface (-editor<%>))) (define pasteboard-mixin - (mixin (-editor<%>) (pasteboard<%>) args - (override - [get-editor<%> (lambda () (class->interface pasteboard%))] - [get-editor% (lambda () pasteboard:keymap%)]) - (sequence (apply super-init args)))) + (mixin (-editor<%>) (pasteboard<%>) + (override get-editor<%> get-editor%) + [define get-editor<%> (lambda () (class->interface pasteboard%))] + [define get-editor% (lambda () pasteboard:keymap%)] + (super-instantiate ()))) (define (search-dialog frame) (init-find/replace-edits) @@ -1246,102 +1199,106 @@ (send replace-edit get-keymap))))) (define searchable-mixin - (mixin (standard-menus<%>) (searchable<%>) args - (sequence (init-find/replace-edits)) + (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]) - (private-field - [super-root 'unitiaialized-super-root]) - (override - [edit-menu:find-callback (lambda (menu evt) (move-to-search-or-search) #t)] - [edit-menu:create-find? (lambda () #t)] - [edit-menu:find-again-callback (lambda (menu evt) (search-again) #t)] - [edit-menu:create-find-again? (lambda () #t)] - [edit-menu:replace-and-find-again-callback (lambda (menu evt) (replace&search) #t)] - [edit-menu:replace-and-find-again-on-demand - (lambda (item) (send item enable (can-replace?)))] - [edit-menu:create-replace-and-find-again? (lambda () #t)]) - (override - [make-root-area-container - (lambda (% parent) - (let* ([s-root (super-make-root-area-container - vertical-panel% - parent)] - [root (make-object % s-root)]) - (set! super-root s-root) - root))]) - (override - [on-activate - (lambda (on?) - (unless hidden? - (if on? - (reset-search-anchor (get-text-to-search)) - (clear-search-highlight))) - (super-on-activate on?))]) - (public - [get-text-to-search - (lambda () - (error 'get-text-to-search "abstract method in searchable-mixin"))] - [hide-search - (opt-lambda ([startup? #f]) - (send super-root change-children - (lambda (l) - (remove search-panel l))) - (clear-search-highlight) - (unless startup? - (send - (send (get-text-to-search) get-canvas) - focus)) - (set! hidden? #t))] - [unhide-search - (lambda () - (when (and hidden? - (not (preferences:get 'framework:search-using-dialog?))) - (set! hidden? #f) - (send search-panel focus) - (send super-root add-child search-panel) - (reset-search-anchor (get-text-to-search))))]) - (private-field - [remove-callback - (preferences:add-callback - 'framework:search-using-dialog? - (lambda (p v) - (when p - (hide-search))))]) - (override - [on-close - (lambda () - (super-on-close) - (remove-callback) - (let ([close-canvas - (lambda (canvas edit) - (send canvas set-editor #f))]) - (close-canvas find-canvas find-edit) - (close-canvas replace-canvas replace-edit)) - (when (eq? this searching-frame) - (set-searching-frame #f)))]) - (public - [set-search-direction - (lambda (x) - (set-searching-direction x) - (send dir-radio set-selection (if (eq? x 'forward) 0 1)))] - [can-replace? - (lambda () - (let ([tx (get-text-to-search)]) - (and - tx - (not (= 0 (send replace-edit last-position))) - (string=? - (send tx get-text - (send tx get-start-position) - (send tx get-end-position)) - (send find-edit get-text 0 (send find-edit last-position))))))] - [replace&search + [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 + (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 + (lambda (% parent) + (let* ([s-root (super-make-root-area-container + vertical-panel% + parent)] + [root (make-object % s-root)]) + (set! super-root s-root) + root))] + (override on-activate) + [define on-activate + (lambda (on?) + (unless hidden? + (if on? + (reset-search-anchor (get-text-to-search)) + (clear-search-highlight))) + (super-on-activate on?))] + + (public get-text-to-search hide-search unhide-search) + [define get-text-to-search + (lambda () + (error 'get-text-to-search "abstract method in searchable-mixin"))] + [define hide-search + (opt-lambda ([startup? #f]) + (send super-root change-children + (lambda (l) + (remove search-panel l))) + (clear-search-highlight) + (unless startup? + (send + (send (get-text-to-search) get-canvas) + focus)) + (set! hidden? #t))] + [define unhide-search + (lambda () + (when (and hidden? + (not (preferences:get 'framework:search-using-dialog?))) + (set! hidden? #f) + (send search-panel focus) + (send super-root add-child search-panel) + (reset-search-anchor (get-text-to-search))))] + [define remove-callback + (preferences:add-callback + 'framework:search-using-dialog? + (lambda (p v) + (when p + (hide-search))))] + (override on-close) + [define on-close + (lambda () + (super-on-close) + (remove-callback) + (let ([close-canvas + (lambda (canvas edit) + (send canvas set-editor #f))]) + (close-canvas find-canvas find-edit) + (close-canvas replace-canvas replace-edit)) + (when (eq? this searching-frame) + (set-searching-frame #f)))] + (public set-search-direction can-replace? replace&search replace-all replace + toggle-search-focus move-to-search-or-search move-to-search-or-reverse-search + search-again) + [define set-search-direction + (lambda (x) + (set-searching-direction x) + (send dir-radio set-selection (if (eq? x 'forward) 0 1)))] + [define can-replace? + (lambda () + (let ([tx (get-text-to-search)]) + (and + tx + (not (= 0 (send replace-edit last-position))) + (string=? + (send tx get-text + (send tx get-start-position) + (send tx get-end-position)) + (send find-edit get-text 0 (send find-edit last-position))))))] + [define replace&search (lambda () (when (replace) (search-again)))] - [replace-all + [define replace-all (lambda () (let* ([replacee-edit (get-text-to-search)] [pos (if (eq? searching-direction 'forward) @@ -1360,7 +1317,7 @@ (replace) (loop)))) (send replacee-edit end-edit-sequence)))] - [replace + [define replace (lambda () (let* ([search-text (send find-edit get-text)] [replacee-edit (get-text-to-search)] @@ -1376,7 +1333,7 @@ (+ replacee-start (string-length new-text))) #t) #f)))] - [toggle-search-focus + [define toggle-search-focus (lambda () (set-searching-frame this) (unhide-search) @@ -1388,7 +1345,7 @@ [else find-canvas]) focus))] - [move-to-search-or-search + [define move-to-search-or-search (lambda () (set-searching-frame this) (unhide-search) @@ -1400,7 +1357,7 @@ (send replace-canvas has-focus?)) (search-again 'forward) (send find-canvas focus))]))] - [move-to-search-or-reverse-search + [define move-to-search-or-reverse-search (lambda () (set-searching-frame this) (unhide-search) @@ -1408,87 +1365,86 @@ (send replace-canvas has-focus?)) (search-again 'backward) (send find-canvas focus)))] - [search-again + [define search-again (opt-lambda ([direction searching-direction] [beep? #t]) (set-searching-frame this) (unhide-search) (set-search-direction direction) - (send find-edit search #t beep?))]) - (sequence - (apply super-init args)) - (private-field - [search-panel (make-object horizontal-panel% super-root '(border))] - - [left-panel (make-object vertical-panel% search-panel)] - [find-canvas (make-object searchable-canvas% left-panel)] - [replace-canvas (make-object searchable-canvas% left-panel)] - - [middle-left-panel (make-object vertical-pane% search-panel)] - [middle-middle-panel (make-object vertical-pane% search-panel)] - [middle-right-panel (make-object vertical-pane% search-panel)] - - [search-button (make-object button% - "Search" - middle-left-panel - (lambda args (search-again)))] - - [replace&search-button (make-object button% - "Replace && Search" - middle-middle-panel - (lambda x (replace&search)))] - [replace-button (make-object button% "Replace" middle-left-panel (lambda x (replace)))] - [replace-all-button (make-object button% - "Replace To End" - middle-middle-panel - (lambda x (replace-all)))] - - [dir-radio (make-object radio-box% - #f - (list "Forward" "Backward") - middle-right-panel - (lambda (dir-radio evt) - (let ([forward (if (= (send dir-radio get-selection) 0) - 'forward - 'backward)]) - (set-search-direction forward) - (reset-search-anchor (get-text-to-search)))))] - [close-button (make-object button% "Hide" - middle-right-panel - (lambda args (hide-search)))] - [hidden? #f]) - (sequence - (let ([align - (lambda (x y) - (let ([m (max (send x get-width) - (send y get-width))]) - (send x min-width m) - (send y min-width m)))]) - (align search-button replace-button) - (align replace&search-button replace-all-button)) - (for-each (lambda (x) (send x set-alignment 'center 'center)) - (list middle-left-panel middle-middle-panel)) - (for-each (lambda (x) (send x stretchable-height #f)) - (list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel)) - (for-each (lambda (x) (send x stretchable-width #f)) - (list middle-left-panel middle-middle-panel middle-right-panel)) - (send find-canvas set-editor find-edit) - (send replace-canvas set-editor replace-edit) - (hide-search #t)))) + (send find-edit search #t beep?))] + + (super-instantiate ()) + + [define search-panel (make-object horizontal-panel% super-root '(border))] + + [define left-panel (make-object vertical-panel% search-panel)] + [define find-canvas (make-object searchable-canvas% left-panel)] + [define replace-canvas (make-object searchable-canvas% left-panel)] + + [define middle-left-panel (make-object vertical-pane% search-panel)] + [define middle-middle-panel (make-object vertical-pane% search-panel)] + [define middle-right-panel (make-object vertical-pane% search-panel)] + + [define search-button (make-object button% + "Search" + middle-left-panel + (lambda args (search-again)))] + + [define replace&search-button (make-object button% + "Replace && Search" + middle-middle-panel + (lambda x (replace&search)))] + [define replace-button (make-object button% "Replace" middle-left-panel (lambda x (replace)))] + [define replace-all-button (make-object button% + "Replace To End" + middle-middle-panel + (lambda x (replace-all)))] + + [define dir-radio (make-object radio-box% + #f + (list "Forward" "Backward") + middle-right-panel + (lambda (dir-radio evt) + (let ([forward (if (= (send dir-radio get-selection) 0) + 'forward + 'backward)]) + (set-search-direction forward) + (reset-search-anchor (get-text-to-search)))))] + [define close-button (make-object button% "Hide" + middle-right-panel + (lambda args (hide-search)))] + [define hidden? #f] + + (let ([align + (lambda (x y) + (let ([m (max (send x get-width) + (send y get-width))]) + (send x min-width m) + (send y min-width m)))]) + (align search-button replace-button) + (align replace&search-button replace-all-button)) + (for-each (lambda (x) (send x set-alignment 'center 'center)) + (list middle-left-panel middle-middle-panel)) + (for-each (lambda (x) (send x stretchable-height #f)) + (list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel)) + (for-each (lambda (x) (send x stretchable-width #f)) + (list middle-left-panel middle-middle-panel middle-right-panel)) + (send find-canvas set-editor find-edit) + (send replace-canvas set-editor replace-edit) + (hide-search #t))) (define searchable-text<%> (interface (searchable<%> text<%>))) (define searchable-text-mixin - (mixin (text<%> searchable<%>) (searchable-text<%>) args + (mixin (text<%> searchable<%>) (searchable-text<%>) (inherit get-editor) - (override - [get-text-to-search - (lambda () - (get-editor))]) - (override - [get-editor<%> (lambda () text:searching<%>)] - [get-editor% (lambda () text:searching%)]) - (sequence (apply super-init args)))) - + (override get-text-to-search) + [define get-text-to-search + (lambda () + (get-editor))] + (override get-editor<%> get-editor%) + [define get-editor<%> (lambda () text:searching<%>)] + [define get-editor% (lambda () text:searching%)] + (super-instantiate ()))) ; to see printouts in memory debugging better. (define memory-text% (class100 text% args (sequence (apply super-init args)))) @@ -1498,29 +1454,29 @@ (define file<%> (interface (-editor<%>))) (define file-mixin - (mixin (-editor<%>) (file<%>) args + (mixin (-editor<%>) (file<%>) (inherit get-editor get-filename get-label) (rename [super-can-close? can-close?]) - (override - [can-close? - (lambda () - (let* ([edit (get-editor)] - [user-allowed-or-not-modified - (or (not (send edit is-modified?)) - (case (gui-utils:unsaved-warning - (let ([fn (get-filename)]) - (if (string? fn) - fn - (get-label))) - "Close" - #t - this) - [(continue) #t] - [(save) (send edit save-file)] - [else #f]))]) - (and user-allowed-or-not-modified - (super-can-close?))))]) - (sequence (apply super-init args)))) + (override can-close?) + [define can-close? + (lambda () + (let* ([edit (get-editor)] + [user-allowed-or-not-modified + (or (not (send edit is-modified?)) + (case (gui-utils:unsaved-warning + (let ([fn (get-filename)]) + (if (string? fn) + fn + (get-label))) + "Close" + #t + this) + [(continue) #t] + [(save) (send edit save-file)] + [else #f]))]) + (and user-allowed-or-not-modified + (super-can-close?))))] + (super-instantiate ()))) (define basic% (basic-mixin frame%)) (define info% (info-mixin basic%)) diff --git a/collects/framework/private/gen-standard-menus.ss b/collects/framework/private/gen-standard-menus.ss index d4cacafb..4d210a12 100644 --- a/collects/framework/private/gen-standard-menus.ss +++ b/collects/framework/private/gen-standard-menus.ss @@ -1,44 +1,54 @@ (module gen-standard-menus mzscheme (require (lib "pretty.ss")) (require (lib "list.ss")) - (require (lib "standard-menus-items.ss" "framework" "private")) + (require "standard-menus-items.ss") - ;; build-before-super-item-clause : an-item -> sexp - ;; calculates a `public' class expression + ;; build-before-super-item-clause : an-item -> (listof clause) (define build-before-super-item-clause (lambda (item) - `(public - [,(an-item->callback-name item) + (list + `(public ,(an-item->callback-name item) + ,(an-item->get-item-name item) + ,(an-item->string-name item) + ,(an-item->help-string-name item) + ,(an-item->on-demand-name item) + ,(an-item->create-menu-item-name item)) + `[define ,(an-item->callback-name item) ,(or (an-item-proc item) `(lambda (x y) (void)))] - [,(an-item->get-item-name item) + `[define ,(an-item->get-item-name item) (lambda () ,(an-item->item-name item))] - [,(an-item->string-name item) + `[define ,(an-item->string-name item) (lambda () "")] - [,(an-item->help-string-name item) + `[define ,(an-item->help-string-name item) (lambda () ,(an-item-help-string item))] - [,(an-item->on-demand-name item) + `[define ,(an-item->on-demand-name item) ,(an-item-on-demand item)] - [,(an-item->create-menu-item-name item) + `[define ,(an-item->create-menu-item-name item) (lambda () ,(not (not (an-item-proc item))))]))) + ;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause)) (define build-before-super-clause (lambda (->name -procedure) (lambda (obj) - `(public - [,(->name obj) - ,(case (-procedure obj) - [(nothing) '(lambda (menu) (void))] - [(separator) '(lambda (menu) (make-object separator-menu-item% menu))])])))) + (list `(public ,(->name obj)) + `[define ,(->name obj) + ,(case (-procedure obj) + [(nothing) '(lambda (menu) (void))] + [(separator) '(lambda (menu) (make-object separator-menu-item% menu))])])))) + ;; build-before-super-between-clause : between -> (listof clause) (define build-before-super-between-clause (build-before-super-clause between->name between-procedure)) + + ;; build-before-super-before/after-clause : before/after -> (listof clause) (define build-before-super-before/after-clause (build-before-super-clause before/after->name before/after-procedure)) + ;; build-after-super-item-clause : an-item -> (list clause) (define (build-after-super-item-clause item) (let* ([callback-name (an-item->callback-name item)] [create-menu-item-name (an-item->create-menu-item-name item)] @@ -53,59 +63,58 @@ (if (string=? special "") (string-append base suffix) (string-append base " " special suffix))))]) - `(private-field - [,(an-item->item-name item) - (and (,create-menu-item-name) - (make-object (class100 (get-menu-item%) args - (rename [super-on-demand on-demand]) - (override - [on-demand - (lambda () - (,(an-item->on-demand-name item) this) - (super-on-demand))]) - (sequence - (apply super-init args))) - ,(join menu-before-string menu-after-string - `(,(an-item->string-name item))) - ,(menu-item-menu-name item) - (let ([,callback-name (lambda (item evt) (,callback-name item evt))]) - ,callback-name) - ,key - (,(an-item->help-string-name item))))]))) + (list `(define + ,(an-item->item-name item) + (and (,create-menu-item-name) + (instantiate (get-menu-item%) () + (label ,(join menu-before-string menu-after-string + `(,(an-item->string-name item)))) + (parent ,(menu-item-menu-name item)) + (callback (let ([,callback-name (lambda (item evt) (,callback-name item evt))]) + ,callback-name)) + (shortcut ,key) + (help (,(an-item->help-string-name item))) + (demand-callback (lambda (menu-item) (,(an-item->on-demand-name item) menu-item))))))))) + ;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause)) (define build-after-super-clause (lambda (->name) (lambda (between/after) - `(sequence - (,(->name between/after) - (,(menu-name->get-menu-name between/after))))))) + (list + `(,(->name between/after) + (,(menu-name->get-menu-name between/after))))))) + ;; build-after-super-between-clause : between -> (listof clause) (define build-after-super-between-clause (build-after-super-clause between->name)) + ;; build-after-super-before/after-clause : before/after -> (listof clause) (define build-after-super-before/after-clause (build-after-super-clause before/after->name)) + ;; build-after-super-generic-clause : generic -> (listof clause) (define (build-after-super-generic-clause x) (cond [(generic-private-field? x) - `(private-field - [,(generic-name x) - ,(generic-initializer x)])] + (list `(define + ,(generic-name x) + ,(generic-initializer x)))] [(generic-override? x) - `(rename [,(string->symbol (format "super-~a" (generic-name x))) - ,(generic-name x)])] + (list `(rename [,(string->symbol (format "super-~a" (generic-name x))) + ,(generic-name x)]))] [(generic-method? x) - `(sequence (void))])) + null])) + + ;; build-before-super-generic-clause : generic -> (listof clause) (define (build-before-super-generic-clause generic) (cond [(generic-private-field? generic) - `(sequence (void))] + null] [(generic-override? generic) - `(override - [,(generic-name generic) - ,(generic-initializer generic)])] + (list `(override ,(generic-name generic)) + `[define ,(generic-name generic) + ,(generic-initializer generic)])] [(generic-method? generic) - `(public - [,(generic-name generic) - ,(generic-initializer generic)])])) + (list `(public ,(generic-name generic) ) + `[define ,(generic-name generic) + ,(generic-initializer generic)])])) (define standard-menus.ss-filename (build-path (collection-path "framework" "private") "standard-menus.ss")) @@ -141,10 +150,9 @@ (pretty-print `(define standard-menus-mixin - (mixin (basic<%>) (standard-menus<%>) args + (mixin (basic<%>) (standard-menus<%>) (inherit on-menu-char on-traverse-char) - (private-field - [remove-prefs-callback + (define remove-prefs-callback (preferences:add-callback 'framework:menu-bindings (lambda (p v) @@ -157,26 +165,26 @@ (when (is-a? menu menu:can-restore<%>) (if v (send menu restore-keybinding) - (send menu set-shortcut #f)))])))))]) + (send menu set-shortcut #f)))])))))) (inherit get-menu-bar show can-close? get-edit-target-object) - ,@(map (lambda (x) - (cond - [(between? x) (build-before-super-between-clause x)] - [(or (after? x) (before? x)) (build-before-super-before/after-clause x)] - [(an-item? x) (build-before-super-item-clause x)] - [(generic? x) (build-before-super-generic-clause x)] - [else (printf "~a~n" x)])) - items) - (sequence (apply super-init args)) - ,@(map (lambda (x) - (cond - [(between? x) (build-after-super-between-clause x)] - [(an-item? x) (build-after-super-item-clause x)] - [(or (after? x) (before? x)) (build-after-super-before/after-clause x)] - [(generic? x) (build-after-super-generic-clause x)])) - items) - (sequence (reorder-menus this)))) + ,@(apply append (map (lambda (x) + (cond + [(between? x) (build-before-super-between-clause x)] + [(or (after? x) (before? x)) (build-before-super-before/after-clause x)] + [(an-item? x) (build-before-super-item-clause x)] + [(generic? x) (build-before-super-generic-clause x)] + [else (printf "~a~n" x)])) + items)) + (super-instantiate ()) + ,@(apply append (map (lambda (x) + (cond + [(between? x) (build-after-super-between-clause x)] + [(an-item? x) (build-after-super-item-clause x)] + [(or (after? x) (before? x)) (build-after-super-before/after-clause x)] + [(generic? x) (build-after-super-generic-clause x)])) + items)) + (reorder-menus this))) port)) 'text - 'truncate)) + 'truncate)) \ No newline at end of file diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 92f5489c..bc4d9521 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -26,53 +26,52 @@ get-map-function-table/ht)) (define aug-keymap-mixin - (mixin ((class->interface keymap%)) (aug-keymap<%>) args - (private-field - [chained-keymaps null]) - (public - [get-chained-keymaps - (lambda () - chained-keymaps)]) + (mixin ((class->interface keymap%)) (aug-keymap<%>) + (define chained-keymaps null) + (public get-chained-keymaps) + [define get-chained-keymaps + (lambda () + chained-keymaps)] (rename [super-chain-to-keymap chain-to-keymap]) - (override - [chain-to-keymap + (override chain-to-keymap) + [define chain-to-keymap (lambda (keymap prefix?) (super-chain-to-keymap keymap prefix?) (set! chained-keymaps (if prefix? (cons keymap chained-keymaps) - (append chained-keymaps (list keymap)))))]) + (append chained-keymaps (list keymap)))))] - (private-field [function-table (make-hash-table)]) - (public [get-function-table (lambda () function-table)]) + [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 + (override map-function) + [define map-function (lambda (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 - (lambda () - (get-map-function-table/ht (make-hash-table)))] - - [get-map-function-table/ht - (lambda (table) - (hash-table-for-each - function-table - (lambda (keyname fname) - (unless (hash-table-get table keyname (lambda () #f)) - (hash-table-put! table keyname fname)))) - (for-each - (lambda (chained-keymap) - (when (is-a? chained-keymap aug-keymap<%>) - (send chained-keymap get-map-function-table/ht table))) - chained-keymaps) - table)]) - - (sequence - (apply super-init args)))) + (public get-map-function-table get-map-function-table/ht) + [define get-map-function-table + (lambda () + (get-map-function-table/ht (make-hash-table)))] + + [define get-map-function-table/ht + (lambda (table) + (hash-table-for-each + function-table + (lambda (keyname fname) + (unless (hash-table-get table keyname (lambda () #f)) + (hash-table-put! table keyname fname)))) + (for-each + (lambda (chained-keymap) + (when (is-a? chained-keymap aug-keymap<%>) + (send chained-keymap get-map-function-table/ht table))) + chained-keymaps) + table)] + + (super-instantiate ()))) (define aug-keymap% (aug-keymap-mixin keymap%)) diff --git a/collects/framework/private/menu.ss b/collects/framework/private/menu.ss index 45b000ac..735626b4 100644 --- a/collects/framework/private/menu.ss +++ b/collects/framework/private/menu.ss @@ -18,20 +18,19 @@ restore-keybinding)) (define can-restore-mixin - (mixin (selectable-menu-item<%>) (can-restore<%>) args + (mixin (selectable-menu-item<%>) (can-restore<%>) (inherit set-shortcut get-shortcut) - (private-field - [saved-shortcut 'not-yet]) - (public - [restore-keybinding - (lambda () - (unless (eq? saved-shortcut 'not-yet) - (set-shortcut saved-shortcut)))]) - (sequence - (apply super-init args) - (set! saved-shortcut (get-shortcut)) - (unless (preferences:get 'framework:menu-bindings) - (set-shortcut #f))))) + [define saved-shortcut 'not-yet] + (public restore-keybinding) + [define restore-keybinding + (lambda () + (unless (eq? saved-shortcut 'not-yet) + (set-shortcut saved-shortcut)))] + + (super-instantiate ()) + (set! saved-shortcut (get-shortcut)) + (unless (preferences:get 'framework:menu-bindings) + (set-shortcut #f)))) (define can-restore-menu-item% (can-restore-mixin menu-item%)) (define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%))))) \ No newline at end of file diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index 826ba87f..e5fcf681 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -27,21 +27,21 @@ (define single<%> (interface (area-container<%>) active-child)) (define single-mixin - (mixin (area-container<%>) (single<%>) args + (mixin (area-container<%>) (single<%>) (inherit get-alignment) (rename [super-after-new-child after-new-child]) - (override - [after-new-child - (lambda (c) - (if current-active-child - (send c show #f) - (set! current-active-child c)))] - [container-size - (lambda (l) - (if (null? l) - (values 0 0) - (values (apply max (map car l)) (apply max (map cadr l)))))] - [place-children + (override after-new-child container-size place-children) + [define after-new-child + (lambda (c) + (if current-active-child + (send c show #f) + (set! current-active-child c)))] + [define container-size + (lambda (l) + (if (null? l) + (values 0 0) + (values (apply max (map car l)) (apply max (map cadr l)))))] + [define place-children (lambda (l width height) (let-values ([(h-align-spec v-align-spec) (get-alignment)]) (let ([align @@ -61,32 +61,31 @@ (values 0 height) (values (align height v-align-spec min-height) min-height))]) (list x y this-width this-height))) - l))))]) + l))))] (inherit get-children) - (private-field [current-active-child #f]) - (public - [active-child - (case-lambda - [() current-active-child] - [(x) - (unless (memq x (get-children)) - (error 'active-child "got a panel that is not a child: ~e" x)) - (unless (eq? x current-active-child) - (for-each (lambda (x) (send x show #f)) - (get-children)) - (set! current-active-child x) - (send current-active-child show #t))])]) - (sequence - (apply super-init args)))) + [define current-active-child #f] + (public active-child) + [define active-child + (case-lambda + [() current-active-child] + [(x) + (unless (memq x (get-children)) + (error 'active-child "got a panel that is not a child: ~e" x)) + (unless (eq? x current-active-child) + (for-each (lambda (x) (send x show #f)) + (get-children)) + (set! current-active-child x) + (send current-active-child show #t))])] + (super-instantiate ()))) (define single-window<%> (interface (single<%> window<%>))) (define single-window-mixin - (mixin (single<%> window<%>) (single-window<%>) args + (mixin (single<%> window<%>) (single-window<%>) (inherit get-client-size get-size) (rename [super-container-size container-size]) - (override - [container-size + (override container-size) + [define container-size (lambda (l) (let-values ([(super-width super-height) (super-container-size l)] [(client-width client-height) (get-client-size)] @@ -97,9 +96,8 @@ (values (calc-size super-width client-width window-width) - (calc-size super-height client-height window-height))))]) - (sequence - (apply super-init args)))) + (calc-size super-height client-height window-height))))] + (super-instantiate ()))) (define multi-view<%> (interface (area-container<%>) @@ -108,63 +106,59 @@ collapse)) (define multi-view-mixin - (mixin (area-container<%>) (multi-view<%>) (_parent _editor) - - (private-field [parent _parent] - [editor _editor]) - - (public - [get-editor-canvas% - (lambda () - editor-canvas%)] - [get-vertical% - (lambda () - vertical-panel%)] - [get-horizontal% - (lambda () - horizontal-panel%)]) - + (mixin (area-container<%>) (multi-view<%>) + (init-field parent editor) + (public get-editor-canvas% get-vertical% get-horizontal%) + [define get-editor-canvas% + (lambda () + editor-canvas%)] + [define get-vertical% + (lambda () + vertical-panel%)] + [define get-horizontal% + (lambda () + horizontal-panel%)] - (private - [split - (lambda (p%) - (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] - [ec% (get-editor-canvas%)]) - (when (and canvas - (is-a? canvas ec%) - (eq? (send canvas get-editor) editor)) - (let ([p (send canvas get-parent)]) - (send p change-children (lambda (x) null)) - (let ([pc (make-object p% p)]) - (send (make-object ec% (make-object vertical-panel% pc) editor) focus) - (make-object ec% (make-object vertical-panel% pc) editor))))))]) + (public split-vertically split-horizontally) + + [define split + (lambda (p%) + (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] + [ec% (get-editor-canvas%)]) + (when (and canvas + (is-a? canvas ec%) + (eq? (send canvas get-editor) editor)) + (let ([p (send canvas get-parent)]) + (send p change-children (lambda (x) null)) + (let ([pc (make-object p% p)]) + (send (make-object ec% (make-object vertical-panel% pc) editor) focus) + (make-object ec% (make-object vertical-panel% pc) editor))))))] + [define split-vertically + (lambda () + (split (get-vertical%)))] + [define split-horizontally + (lambda () + (split (get-horizontal%)))] + + (public collapse) + (define collapse + (lambda () + (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] + [ec% (get-editor-canvas%)]) + (when (and canvas + (is-a? canvas ec%) + (eq? (send canvas get-editor) editor)) + (let ([p (send canvas get-parent)]) + (if (eq? p this) + (bell) + (let* ([sp (send p get-parent)] + [p-to-remain (send sp get-parent)]) + (send p-to-remain change-children (lambda (x) null)) + (send (make-object ec% p-to-remain editor) focus)))))))) - (public - [collapse - (lambda () - (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] - [ec% (get-editor-canvas%)]) - (when (and canvas - (is-a? canvas ec%) - (eq? (send canvas get-editor) editor)) - (let ([p (send canvas get-parent)]) - (if (eq? p this) - (bell) - (let* ([sp (send p get-parent)] - [p-to-remain (send sp get-parent)]) - (send p-to-remain change-children (lambda (x) null)) - (send (make-object ec% p-to-remain editor) focus)))))))]) - (public - [split-vertically - (lambda () - (split (get-vertical%)))] - [split-horizontally - (lambda () - (split (get-horizontal%)))]) - (sequence - (super-init parent) - (make-object (get-editor-canvas%) this editor)))) + (super-instantiate () (parent parent)) + (make-object (get-editor-canvas%) this editor))) (define single% (single-window-mixin (single-mixin panel%))) (define single-pane% (single-mixin pane%)) @@ -377,30 +371,29 @@ set-percentages)) (define vertical-resizable-mixin - (mixin (area-container<%>) (vertical-resizable<%>) args + (mixin (area-container<%>) (vertical-resizable<%>) (inherit get-children) - (private-field [thumb-canvas #f]) - (public - [on-between-click - (lambda (num pct) - (void))]) + (define thumb-canvas #f) + (public on-between-click) + [define on-between-click + (lambda (num pct) + (void))] ;; preserve the invariant that the thumb-canvas is ;; the first child and that the thumb-canvas percentages ;; match up with the children - (private - [fix-percentage-length - (lambda (children) - (let ([len (length children)]) - (unless (= (- len 1) (length (send thumb-canvas get-percentages))) - (send thumb-canvas set-percentages - (build-list - (- len 1) - (lambda (i) (/ 1 (- len 1))))))))]) + [define fix-percentage-length + (lambda (children) + (let ([len (length children)]) + (unless (= (- len 1) (length (send thumb-canvas get-percentages))) + (send thumb-canvas set-percentages + (build-list + (- len 1) + (lambda (i) (/ 1 (- len 1))))))))] (rename [super-change-children change-children]) - (override - [change-children + (override change-children after-new-child) + [define change-children (lambda (f) (super-change-children (lambda (l) @@ -413,13 +406,13 @@ (fix-percentage-length res) res) (f l)))))] - [after-new-child + [define after-new-child (lambda (child) (when thumb-canvas - (fix-percentage-length (get-children))))]) + (fix-percentage-length (get-children))))] - (override - [container-size + (override container-size place-children) + [define container-size (lambda (_lst) ;; remove the thumb canvas from the computation (let ([lst (if (null? _lst) null (cdr _lst))]) @@ -431,59 +424,58 @@ (+ (send thumb-canvas min-width) (apply max (map car lst)))]) (apply + (map cadr lst)))))] - [place-children + [define place-children (lambda (_infos width height) (cond - [(null? _infos) null] - [(null? (cdr _infos)) (list (list 0 0 0 0))] - [(null? (cdr (cdr _infos))) - (list (list 0 0 0 0) - (list 0 0 width height))] - [else - (fix-percentage-length (get-children)) - (cons - (list (- width (send thumb-canvas min-width)) 0 - (send thumb-canvas min-width) - height) - (let ([main-width (- width (send thumb-canvas min-width))] - [show-error - (lambda () - (error 'panel:vertical-resizable-mixin:place-children - "expected children list(~a) to be one longer than percentage list(~a), info: ~e percentages ~e" - (length _infos) (length (send thumb-canvas get-percentages)) - _infos (send thumb-canvas get-percentages)))]) - (let loop ([percentages (send thumb-canvas get-percentages)] - [infos (cdr _infos)] - [y 0]) - (cond - [(null? percentages) - (unless (null? infos) (show-error)) - null] - [(null? (cdr percentages)) - (when (null? infos) (show-error)) - (unless (null? (cdr infos)) (show-error)) - (list (list 0 y main-width (- height y)))] - [else - (when (null? infos) (show-error)) - (let* ([info (car infos)] - [percentage (car percentages)] - [this-space (floor (* percentage height))]) - (cons (list 0 y main-width this-space) - (loop (cdr percentages) - (cdr infos) - (+ y this-space))))]))))]))]) + [(null? _infos) null] + [(null? (cdr _infos)) (list (list 0 0 0 0))] + [(null? (cdr (cdr _infos))) + (list (list 0 0 0 0) + (list 0 0 width height))] + [else + (fix-percentage-length (get-children)) + (cons + (list (- width (send thumb-canvas min-width)) 0 + (send thumb-canvas min-width) + height) + (let ([main-width (- width (send thumb-canvas min-width))] + [show-error + (lambda () + (error 'panel:vertical-resizable-mixin:place-children + "expected children list(~a) to be one longer than percentage list(~a), info: ~e percentages ~e" + (length _infos) (length (send thumb-canvas get-percentages)) + _infos (send thumb-canvas get-percentages)))]) + (let loop ([percentages (send thumb-canvas get-percentages)] + [infos (cdr _infos)] + [y 0]) + (cond + [(null? percentages) + (unless (null? infos) (show-error)) + null] + [(null? (cdr percentages)) + (when (null? infos) (show-error)) + (unless (null? (cdr infos)) (show-error)) + (list (list 0 y main-width (- height y)))] + [else + (when (null? infos) (show-error)) + (let* ([info (car infos)] + [percentage (car percentages)] + [this-space (floor (* percentage height))]) + (cons (list 0 y main-width this-space) + (loop (cdr percentages) + (cdr infos) + (+ y this-space))))]))))]))] (inherit reflow-container get-top-level-window set-alignment get-alignment) - (public - [on-percentage-change (lambda () (void))] - [get-percentages (lambda () (send thumb-canvas get-percentages))] - [set-percentages - (lambda (p) - (send thumb-canvas set-percentages p) - (refresh-panel this))]) + (public on-percentage-change get-percentages set-percentages) + [define on-percentage-change (lambda () (void))] + [define get-percentages (lambda () (send thumb-canvas get-percentages))] + [define set-percentages + (lambda (p) + (send thumb-canvas set-percentages p) + (refresh-panel this))] - (sequence - (apply super-init args) - (set! thumb-canvas (make-object thumb-canvas% this))))) + (super-instantiate ()) + (set! thumb-canvas (make-object thumb-canvas% this)))) (define vertical-resizable% (vertical-resizable-mixin panel%)) (define vertical-resizable-pane% (vertical-resizable-mixin pane%))))) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 6b6af18a..5918f5be 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -30,6 +30,8 @@ (rename [-text% text%] [-text<%> text<%>]) + (define-struct string/pos (string pos)) + (define -text<%> (interface () highlight-parens @@ -98,7 +100,7 @@ (define mismatch-color (make-object color% "PINK")) (define text-mixin - (mixin (text:basic<%> editor:keymap<%>) (-text<%>) args + (mixin (text:basic<%> editor:keymap<%>) (-text<%>) (inherit begin-edit-sequence delete end-edit-sequence @@ -126,45 +128,38 @@ set-style-list set-styles-fixed) (rename [super-on-char on-char]) - - (private - [in-single-line-comment? - (lambda (position) - (let ([line (position-line position)]) - (ormap - (lambda (comment-start) - (let loop ([f (find-string comment-start 'backward position)]) - (if f - (cond - [(= (position-line f) line) - (let ([f-1 (- f 2)]) ;; -1 to go back one, -1 to be before char - (cond - [(< f-1 0) - #t] - [(and (= (position-line f-1) line) - (not (char=? (get-character f-1) #\\ ))) - #t] - [else - (loop (find-string comment-start 'backward f-1))]))] - [else - #f]) - #f))) - (scheme-paren:get-comments))))]) - (private-field - [remove-indents-callback - (preferences:add-callback - 'framework:tabify - (lambda (p value) - (set! indents value)))] - [indents (preferences:get 'framework:tabify)] - [backward-cache (make-object match-cache:%)] - [forward-cache (make-object match-cache:%)] - [in-highlight-parens? #f]) - (private - [delay-highlight? (lambda () (local-edit-sequence?))]) - - + (define (in-single-line-comment? position) + (let ([line (position-line position)]) + (ormap + (lambda (comment-start) + (let loop ([f (find-string comment-start 'backward position)]) + (if f + (cond + [(= (position-line f) line) + (let ([f-1 (- f 2)]) ;; -1 to go back one, -1 to be before char + (cond + [(< f-1 0) + #t] + [(and (= (position-line f-1) line) + (not (char=? (get-character f-1) #\\ ))) + #t] + [else + (loop (find-string comment-start 'backward f-1))]))] + [else + #f]) + #f))) + (scheme-paren:get-comments)))) + (define remove-indents-callback + (preferences:add-callback + 'framework:tabify + (lambda (p value) + (set! indents value)))) + (define indents (preferences:get 'framework:tabify)) + [define backward-cache (make-object match-cache:%)] + [define forward-cache (make-object match-cache:%)] + [define in-highlight-parens? #f] + (inherit get-styles-fixed) (rename [super-on-focus on-focus] [super-after-change-style after-change-style] @@ -174,537 +169,537 @@ [super-after-set-size-constraint after-set-size-constraint] [super-after-set-position after-set-position]) (inherit has-focus? find-snip split-snip) - (override - [on-focus - (lambda (on?) - (super-on-focus on?) - (highlight-parens (not on?)))] - [after-change-style - (lambda (start len) - (unless (delay-highlight?) - (unless (get-styles-fixed) - (when (has-focus?) - (highlight-parens)))) - (super-after-change-style start len))] - [after-edit-sequence - (lambda () - (super-after-edit-sequence) - (unless (delay-highlight?) - (when (has-focus?) - (unless in-highlight-parens? - (highlight-parens)))))] - [after-insert - (lambda (start size) - (send backward-cache invalidate start) - (send forward-cache forward-invalidate start size) - (unless (delay-highlight?) - (when (has-focus?) - (highlight-parens))) - (super-after-insert start size))] - [after-delete - (lambda (start size) - (super-after-delete start size) - (send backward-cache invalidate start) - (send forward-cache forward-invalidate (+ start size) (- size)) - (unless (delay-highlight?) - (when (has-focus?) - (highlight-parens))))] - [after-set-size-constraint - (lambda () - (unless (delay-highlight?) - (when (has-focus?) - (highlight-parens))) - (super-after-set-size-constraint))] - [after-set-position - (lambda () - (unless (delay-highlight?) - (when (has-focus?) - (highlight-parens))) - (super-after-set-position))]) + (override on-focus after-change-style after-edit-sequence + after-insert after-delete + after-set-size-constraint after-set-position) + (define (on-focus on?) + (super-on-focus on?) + (highlight-parens (not on?))) + (define (after-change-style start len) + (unless (local-edit-sequence?) + (unless (get-styles-fixed) + (when (has-focus?) + (highlight-parens)))) + (super-after-change-style start len)) + (define (after-edit-sequence) + (super-after-edit-sequence) + (unless (local-edit-sequence?) + (when (has-focus?) + (unless in-highlight-parens? + (highlight-parens))))) + (define (after-insert start size) + (send backward-cache invalidate start) + (send forward-cache forward-invalidate start size) + (unless (local-edit-sequence?) + (when (has-focus?) + (highlight-parens))) + (super-after-insert start size)) + (define (after-delete start size) + (super-after-delete start size) + (send backward-cache invalidate start) + (send forward-cache forward-invalidate (+ start size) (- size)) + (unless (local-edit-sequence?) + (when (has-focus?) + (highlight-parens)))) + (define (after-set-size-constraint) + (unless (local-edit-sequence?) + (when (has-focus?) + (highlight-parens))) + (super-after-set-size-constraint)) + (define (after-set-position ) + (unless (local-edit-sequence?) + (when (has-focus?) + (highlight-parens))) + (super-after-set-position)) + + [define highlight-parens? (preferences:get 'framework:highlight-parens)] + [define remove-paren-callback (preferences:add-callback + 'framework:highlight-parens + (lambda (p value) + (set! highlight-parens? value)))] + (define (find-enclosing-paren pos) + (let loop ([pos pos]) + (let ([paren-pos + (let loop ([pairs (scheme-paren:get-paren-pairs)] + [curr-max #f]) + (cond + [(null? pairs) curr-max] + [else (let* ([pair (car pairs)] + [fnd (find-string (car pair) 'backward pos 'eof #f)]) + (if (and fnd curr-max) + (loop (cdr pairs) + (max fnd curr-max)) + (loop (cdr pairs) + (or fnd curr-max))))]))]) + (cond + [(not paren-pos) #f] + [else + (let ([semi-pos (find-string ";" 'backward paren-pos)]) + (cond + [(or (not semi-pos) + (< semi-pos (paragraph-start-position + (position-paragraph paren-pos)))) + paren-pos] + [else (loop (- semi-pos 1))]))])))) - (private-field - [highlight-parens? (preferences:get 'framework:highlight-parens)] - [remove-paren-callback (preferences:add-callback - 'framework:highlight-parens - (lambda (p value) - (set! highlight-parens? value)))]) - (private - [find-enclosing-paren - (lambda (pos) - (let loop ([pos pos]) - (let ([paren-pos - (let loop ([pairs (scheme-paren:get-paren-pairs)] - [curr-max #f]) - (cond - [(null? pairs) curr-max] - [else (let* ([pair (car pairs)] - [fnd (find-string (car pair) 'backward pos 'eof #f)]) - (if (and fnd curr-max) - (loop (cdr pairs) - (max fnd curr-max)) - (loop (cdr pairs) - (or fnd curr-max))))]))]) - (cond - [(not paren-pos) #f] - [else - (let ([semi-pos (find-string ";" 'backward paren-pos)]) - (cond - [(or (not semi-pos) - (< semi-pos (paragraph-start-position - (position-paragraph paren-pos)))) - paren-pos] - [else (loop (- semi-pos 1))]))]))))]) - (private-field - [clear-old-locations void]) - (public - [highlight-parens - (opt-lambda ([just-clear? #f]) - (when highlight-parens? - (set! in-highlight-parens? #t) - (begin-edit-sequence) - (clear-old-locations) - (set! clear-old-locations void) - (unless just-clear? - (let* ([here (get-start-position)] - [there (get-end-position)] - [slash? - (lambda (before after) - (and (>= before 0) - (>= after 0) - (let ([text (get-text before after)]) - (and (string? text) - (>= (string-length text) 1) - (char=? #\\ (string-ref text 0))))))] - [is-paren? - (lambda (f) - (lambda (char) - (ormap (lambda (x) (char=? char (string-ref (f x) 0))) - (scheme-paren:get-paren-pairs))))] - [is-left-paren? (is-paren? car)] - [is-right-paren? (is-paren? cdr)]) - (when (= here there) - + [define clear-old-locations 'dummy] + (set! clear-old-locations void) + + (public highlight-parens) + (define highlight-parens + (opt-lambda ([just-clear? #f]) + (when highlight-parens? + (set! in-highlight-parens? #t) + (begin-edit-sequence) + (clear-old-locations) + (set! clear-old-locations void) + (unless just-clear? + (let* ([here (get-start-position)] + [there (get-end-position)] + [slash? + (lambda (before after) + (and (>= before 0) + (>= after 0) + (let ([text (get-text before after)]) + (and (string? text) + (>= (string-length text) 1) + (char=? #\\ (string-ref text 0))))))] + [is-paren? + (lambda (f) + (lambda (char) + (ormap (lambda (x) (char=? char (string-ref (f x) 0))) + (scheme-paren:get-paren-pairs))))] + [is-left-paren? (is-paren? car)] + [is-right-paren? (is-paren? cdr)]) + (when (= here there) + ;; before, after : (list number number boolean) ;; numbers indicate the range to highlight ;; boolean indicates if it is an errorneous highlight - (let ([before - (cond - [(and (> here 0) - (is-right-paren? (get-character (sub1 here))) - (not (in-single-line-comment? here))) - (cond - [(slash? (- here 2) (- here 1)) #f] - [(scheme-paren:backward-match - this here (get-limit here) - backward-cache) - => - (lambda (end-pos) - (list end-pos here #f))] - [else (list (- here 1) here #t)])] - [else #f])] - [after - (cond - [(and (is-left-paren? (get-character here)) - (not (in-single-line-comment? here))) - (cond - [(slash? (- here 1) here) #f] - [(scheme-paren:forward-match - this here (last-position) - forward-cache) - => - (lambda (end-pos) - (list here end-pos #f))] - [else (list here (+ here 1) #t)])] - [else #f])] - [handle-single - (lambda (single) - (let* ([left (first single)] - [right (second single)] - [error? (third single)] - [off (highlight-range - left - right - (if error? mismatch-color match-color) - (icon:get-paren-highlight-bitmap) - (= there here left))]) - (set! clear-old-locations - (let ([old clear-old-locations]) - (lambda () - (old) - (off))))))]) - - (cond - [(and after before) - (handle-single after) - (handle-single before)] - [after (handle-single after)] - [before (handle-single before)] - [else (void)]))))) - (end-edit-sequence) - (set! in-highlight-parens? #f)))] - - [get-limit (lambda (pos) 0)] - - [balance-quotes - (lambda (key) - (let* ([char (send key get-key-code)]) ;; must be a character because of the mapping setup + (let ([before + (cond + [(and (> here 0) + (is-right-paren? (get-character (sub1 here))) + (not (in-single-line-comment? here))) + (cond + [(slash? (- here 2) (- here 1)) #f] + [(scheme-paren:backward-match + this here (get-limit here) + backward-cache) + => + (lambda (end-pos) + (list end-pos here #f))] + [else (list (- here 1) here #t)])] + [else #f])] + [after + (cond + [(and (is-left-paren? (get-character here)) + (not (in-single-line-comment? here))) + (cond + [(slash? (- here 1) here) #f] + [(scheme-paren:forward-match + this here (last-position) + forward-cache) + => + (lambda (end-pos) + (list here end-pos #f))] + [else (list here (+ here 1) #t)])] + [else #f])] + [handle-single + (lambda (single) + (let* ([left (first single)] + [right (second single)] + [error? (third single)] + [off (highlight-range + left + right + (if error? mismatch-color match-color) + (icon:get-paren-highlight-bitmap) + (= there here left))]) + (set! clear-old-locations + (let ([old clear-old-locations]) + (lambda () + (old) + (off))))))]) + + (cond + [(and after before) + (handle-single after) + (handle-single before)] + [after (handle-single after)] + [before (handle-single before)] + [else (void)]))))) + (end-edit-sequence) + (set! in-highlight-parens? #f)))) + + (public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection + tabify-all insert-return calc-last-para comment-out-selection uncomment-selection + get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp + flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp + remove-parens-forward) + (define (get-limit pos) 0) + + (define (balance-quotes key) + (let* ([char (send key get-key-code)]) ;; must be a character because of the mapping setup ;; this function is only bound to ascii-returning keys - (insert char) - (let* ([start-pos (get-start-position)] - [limit (get-limit start-pos)] - [match (scheme-paren:backward-match - this start-pos limit backward-cache)]) - (when match - (flash-on match (add1 match))))))] - [balance-parens - (lambda (key-event) - (let-struct string/pos (string pos) - (letrec ([char (send key-event get-key-code)] ;; must be a character. See above. - [here (get-start-position)] - [limit (get-limit here)] - [paren-match? (preferences:get 'framework:paren-match)] - [fixup-parens? (preferences:get 'framework:fixup-parens)] - [find-match - (lambda (pos) - (let loop ([parens (scheme-paren:get-paren-pairs)]) - (cond - [(null? parens) #f] - [else (let* ([paren (car parens)] - [left (car paren)] - [right (cdr paren)]) - (if (string=? left (get-text pos (+ pos (string-length left)))) - right - (loop (cdr parens))))])))]) - (cond - [(in-single-line-comment? here) - (insert char)] - [(and (not (= 0 here)) - (char=? (string-ref (get-text (- here 1) here) 0) #\\)) - (insert char)] - [(or paren-match? fixup-parens?) - (let* ([end-pos (scheme-paren:backward-containing-sexp - this here limit - backward-cache)]) - (cond - [end-pos - (let* ([left-paren-pos (find-enclosing-paren end-pos)] - [match (and left-paren-pos - (find-match left-paren-pos))]) - (cond - [match - (insert (if fixup-parens? match char)) - (when paren-match? - (flash-on - left-paren-pos - (+ left-paren-pos (string-length match))))] - [else - (insert char)]))] - [else (insert char)]))] - [else (insert char)]) - #t)))] - [tabify-on-return? (lambda () #t)] - [tabify - (opt-lambda ([pos (get-start-position)]) - (let* ([last-pos (last-position)] - [para (position-paragraph pos)] - [okay (> para 0)] - [end (if okay (paragraph-start-position para) 0)] - [limit (get-limit pos)] - [contains - (if okay - (scheme-paren:backward-containing-sexp - this end limit backward-cache) - #f)] - [contain-para (and contains - (position-paragraph contains))] - [last - (if contains - (scheme-paren:backward-match this end limit backward-cache) - #f)] - [last-para (and last - (position-paragraph last))]) - (letrec - ([find-offset - (lambda (pos) - (let loop ([p pos][o 0]) - (let ([c (get-character p)]) - (cond - [(char=? c #\tab) - (loop (add1 p) (+ o (- 8 (modulo o 8))))] - [(char=? c #\newline) - (cons o p)] - [(char-whitespace? c) - (loop (add1 p) (add1 o))] - [else - (cons o p)]))))] - [visual-offset - (lambda (pos) - (let loop ([p (sub1 pos)]) - (if (= p -1) - 0 - (let ([c (get-character p)]) - (cond + (insert char) + (let* ([start-pos (get-start-position)] + [limit (get-limit start-pos)] + [match (scheme-paren:backward-match + this start-pos limit backward-cache)]) + (when match + (flash-on match (add1 match)))))) + + (define (balance-parens key-event) + (letrec ([char (send key-event get-key-code)] ;; must be a character. See above. + [here (get-start-position)] + [limit (get-limit here)] + [paren-match? (preferences:get 'framework:paren-match)] + [fixup-parens? (preferences:get 'framework:fixup-parens)] + [find-match + (lambda (pos) + (let loop ([parens (scheme-paren:get-paren-pairs)]) + (cond + [(null? parens) #f] + [else (let* ([paren (car parens)] + [left (car paren)] + [right (cdr paren)]) + (if (string=? left (get-text pos (+ pos (string-length left)))) + right + (loop (cdr parens))))])))]) + (cond + [(in-single-line-comment? here) + (insert char)] + [(and (not (= 0 here)) + (char=? (string-ref (get-text (- here 1) here) 0) #\\)) + (insert char)] + [(or paren-match? fixup-parens?) + (let* ([end-pos (scheme-paren:backward-containing-sexp + this here limit + backward-cache)]) + (cond + [end-pos + (let* ([left-paren-pos (find-enclosing-paren end-pos)] + [match (and left-paren-pos + (find-match left-paren-pos))]) + (cond + [match + (insert (if fixup-parens? match char)) + (when paren-match? + (flash-on + left-paren-pos + (+ left-paren-pos (string-length match))))] + [else + (insert char)]))] + [else (insert char)]))] + [else (insert char)]) + #t)) + + (define (tabify-on-return?) #t) + (define tabify + (opt-lambda ([pos (get-start-position)]) + (let* ([last-pos (last-position)] + [para (position-paragraph pos)] + [okay (> para 0)] + [end (if okay (paragraph-start-position para) 0)] + [limit (get-limit pos)] + [contains + (if okay + (scheme-paren:backward-containing-sexp + this end limit backward-cache) + #f)] + [contain-para (and contains + (position-paragraph contains))] + [last + (if contains + (scheme-paren:backward-match this end limit backward-cache) + #f)] + [last-para (and last + (position-paragraph last))]) + (letrec + ([find-offset + (lambda (pos) + (let loop ([p pos][o 0]) + (let ([c (get-character p)]) + (cond + [(char=? c #\tab) + (loop (add1 p) (+ o (- 8 (modulo o 8))))] + [(char=? c #\newline) + (cons o p)] + [(char-whitespace? c) + (loop (add1 p) (add1 o))] + [else + (cons o p)]))))] + [visual-offset + (lambda (pos) + (let loop ([p (sub1 pos)]) + (if (= p -1) + 0 + (let ([c (get-character p)]) + (cond [(char=? c #\null) 0] [(char=? c #\tab) (let ([o (loop (sub1 p))]) (+ o (- 8 (modulo o 8))))] [(char=? c #\newline) 0] [else (add1 (loop (sub1 p)))])))))] - [do-indent - (lambda (amt) - (let* ([pos-start end] - [curr-offset (find-offset pos-start)]) - (unless (= amt (car curr-offset)) - (delete pos-start (cdr curr-offset)) - (insert - (make-string amt #\space) - pos-start))))] - [id-walker - (lambda (string) - (let ([last (string-length string)]) - (let loop ([index 0]) - (if (= index last) - last - (let ([current (string-ref string index)]) - (if (or (char-alphabetic? current) - (char-numeric? current)) - (loop (add1 index)) - (case current - [(#\# - #\+ #\- #\. #\* #\/ #\< #\= #\> #\! #\? #\: - #\$ #\% #\_ #\& #\^ #\~) - (loop (add1 index))] - [else index])))))))] - [get-proc - (lambda () - (let* ([text (get-text contains (paragraph-end-position contain-para))]) - (hash-table-get indents - (string->symbol (substring text 0 (id-walker text))) - (lambda () 'other))))] - [procedure-indent - (lambda () - (case (get-proc) - [(define) 1] - [(begin) 1] - [(lambda) 3] - [else 0]))] - [special-check - (lambda () - (let* ([proc-name (get-proc)]) - (or (eq? proc-name 'define) - (eq? proc-name 'lambda))))] - [indent-first-arg - (lambda (start) - (car (find-offset start)))]) - (when (and okay - (not (char=? (get-character (sub1 end)) - #\newline))) - (insert #\newline (paragraph-start-position para))) - (cond - [(let ([real-start (cdr (find-offset end))]) - (and (<= (+ 3 real-start) (last-position)) - (string=? ";;" - (get-text real-start - (+ 2 real-start))))) - (void)] - [(= para 0) (do-indent 0)] - [(not contains) - (do-indent 0)] - [(not last) ;; search backwards for the opening parenthesis, and use it to align this line - (let ([enclosing (find-enclosing-paren pos)]) - (do-indent (if enclosing - (+ (visual-offset enclosing) 1) - 0)))] - [(= contains last) - (do-indent (+ (visual-offset contains) - (procedure-indent)))] - [(special-check) - (do-indent (add1 (visual-offset contains)))] - [(= contain-para last-para) - (let ([name-length - (id-walker (get-text contains (paragraph-end-position contain-para)))]) - (do-indent (+ (visual-offset contains) - name-length - (indent-first-arg (+ contains - name-length)))))] - [else - (do-indent (indent-first-arg (paragraph-start-position last-para)))]))))] - [tabify-selection - (opt-lambda ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (let ([first-para (position-paragraph start-pos)] - [end-para (position-paragraph end-pos)]) - (with-handlers ([exn:break? - (lambda (x) #t)]) - (dynamic-wind - (lambda () - (when (< first-para end-para) - (begin-busy-cursor)) - (begin-edit-sequence)) - (lambda () - (let loop ([para first-para]) - (when (<= para end-para) - (tabify (paragraph-start-position para)) - (dynamic-enable-break (lambda () (break-enabled))) - (loop (add1 para)))) - (when (and (>= (position-paragraph start-pos) end-para) - (<= (paren:skip-whitespace - this (get-start-position) 'backward) - (paragraph-start-position first-para))) - (set-position - (let loop ([new-pos (get-start-position)]) - (if (let ([next (get-character new-pos)]) - (and (char-whitespace? next) - (not (char=? next #\newline)))) - (loop (add1 new-pos)) - new-pos))))) - (lambda () - (end-edit-sequence) - (when (< first-para end-para) - (end-busy-cursor)))))))] - [tabify-all (lambda () (tabify-selection 0 (last-position)))] - [insert-return - (lambda () - (if (tabify-on-return?) - (begin - (begin-edit-sequence) - (insert #\newline) - (tabify (get-start-position)) - (set-position - (let loop ([new-pos (get-start-position)]) - (if (let ([next (get-character new-pos)]) - (and (char-whitespace? next) - (not (char=? next #\newline)))) - (loop (add1 new-pos)) - new-pos))) - (end-edit-sequence)) - (insert #\newline)))] - - - [calc-last-para - (lambda (last-pos) - (let ([last-para (position-paragraph last-pos #t)]) - (if (and (> last-pos 0) - (> last-para 0)) - (begin (split-snip last-pos) - (let ([snip (find-snip last-pos 'before)]) - (if (member 'hard-newline (send snip get-flags)) - (- last-para 1) - last-para))) - last-para)))] - [comment-out-selection - (opt-lambda ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (begin-edit-sequence) - (let ([first-pos-is-first-para-pos? - (= (paragraph-start-position (position-paragraph start-pos)) - start-pos)]) - (let* ([first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (if (<= curr-para last-para) - (let ([first-on-para (paragraph-start-position curr-para)]) - (insert #\; first-on-para) - (para-loop (add1 curr-para)))))) - (when first-pos-is-first-para-pos? - (set-position - (paragraph-start-position (position-paragraph (get-start-position))) - (get-end-position)))) - (end-edit-sequence) - #t)] - [uncomment-selection - (opt-lambda ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (begin-edit-sequence) - (let* ([last-pos (last-position)] - [first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (if (<= curr-para last-para) - (let ([first-on-para - (paren:skip-whitespace - this - (paragraph-start-position curr-para) - 'forward)]) - (when (and (< first-on-para last-pos) - (char=? #\; (get-character first-on-para))) - (delete first-on-para (+ first-on-para 1))) - (para-loop (add1 curr-para)))))) - (end-edit-sequence) - #t)] - [get-forward-sexp - (lambda (start-pos) - (scheme-paren:forward-match - this start-pos - (last-position) - forward-cache))] - [remove-sexp - (lambda (start-pos) - (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos - (kill 0 start-pos end-pos) - (bell)) - #t))] - [forward-sexp - (lambda (start-pos) - (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos - (set-position end-pos) - (bell)) - #t))] - [flash-forward-sexp - (lambda (start-pos) - (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos - (flash-on end-pos (add1 end-pos)) - (bell)) - #t))] - [get-backward-sexp - (lambda (start-pos) - (let* ([limit (get-limit start-pos)] - [end-pos - (scheme-paren:backward-match - this start-pos limit backward-cache)] - [min-pos - (scheme-paren:backward-containing-sexp - this start-pos limit backward-cache)] - [ans - (if (and end-pos - (or (not min-pos) - (>= end-pos min-pos))) - end-pos - #f)]) - ans))] - [flash-backward-sexp - (lambda (start-pos) - (let ([end-pos (get-backward-sexp start-pos)]) - (if end-pos - (flash-on end-pos (add1 end-pos)) - (bell)) - #t))] - [backward-sexp - (lambda (start-pos) - (let ([end-pos (get-backward-sexp start-pos)]) - (if end-pos - (set-position end-pos) - (bell)) - #t))] - [find-up-sexp - (lambda (start-pos) - (let* ([exp-pos - (scheme-paren:backward-containing-sexp - this start-pos - (get-limit start-pos) - backward-cache)] - [paren-pos ;; find the closest open paren from this pair, behind exp-pos - (lambda (paren-pair) - (find-string - (car paren-pair) - 'backward - exp-pos))]) - - (if (and exp-pos (> exp-pos 0)) - (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)]) + [do-indent + (lambda (amt) + (let* ([pos-start end] + [curr-offset (find-offset pos-start)]) + (unless (= amt (car curr-offset)) + (delete pos-start (cdr curr-offset)) + (insert + (make-string amt #\space) + pos-start))))] + [id-walker + (lambda (string) + (let ([last (string-length string)]) + (let loop ([index 0]) + (if (= index last) + last + (let ([current (string-ref string index)]) + (if (or (char-alphabetic? current) + (char-numeric? current)) + (loop (add1 index)) + (case current + [(#\# + #\+ #\- #\. #\* #\/ #\< #\= #\> #\! #\? #\: + #\$ #\% #\_ #\& #\^ #\~) + (loop (add1 index))] + [else index])))))))] + [get-proc + (lambda () + (let* ([text (get-text contains (paragraph-end-position contain-para))]) + (hash-table-get indents + (string->symbol (substring text 0 (id-walker text))) + (lambda () 'other))))] + [procedure-indent + (lambda () + (case (get-proc) + [(define) 1] + [(begin) 1] + [(lambda) 3] + [else 0]))] + [special-check + (lambda () + (let* ([proc-name (get-proc)]) + (or (eq? proc-name 'define) + (eq? proc-name 'lambda))))] + [indent-first-arg + (lambda (start) + (car (find-offset start)))]) + (when (and okay + (not (char=? (get-character (sub1 end)) + #\newline))) + (insert #\newline (paragraph-start-position para))) + (cond + [(let ([real-start (cdr (find-offset end))]) + (and (<= (+ 3 real-start) (last-position)) + (string=? ";;" + (get-text real-start + (+ 2 real-start))))) + (void)] + [(= para 0) (do-indent 0)] + [(not contains) + (do-indent 0)] + [(not last) ;; search backwards for the opening parenthesis, and use it to align this line + (let ([enclosing (find-enclosing-paren pos)]) + (do-indent (if enclosing + (+ (visual-offset enclosing) 1) + 0)))] + [(= contains last) + (do-indent (+ (visual-offset contains) + (procedure-indent)))] + [(special-check) + (do-indent (add1 (visual-offset contains)))] + [(= contain-para last-para) + (let ([name-length + (id-walker (get-text contains (paragraph-end-position contain-para)))]) + (do-indent (+ (visual-offset contains) + name-length + (indent-first-arg (+ contains + name-length)))))] + [else + (do-indent (indent-first-arg (paragraph-start-position last-para)))]))))) + + (define tabify-selection + (opt-lambda ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (let ([first-para (position-paragraph start-pos)] + [end-para (position-paragraph end-pos)]) + (with-handlers ([exn:break? + (lambda (x) #t)]) + (dynamic-wind + (lambda () + (when (< first-para end-para) + (begin-busy-cursor)) + (begin-edit-sequence)) + (lambda () + (let loop ([para first-para]) + (when (<= para end-para) + (tabify (paragraph-start-position para)) + (dynamic-enable-break (lambda () (break-enabled))) + (loop (add1 para)))) + (when (and (>= (position-paragraph start-pos) end-para) + (<= (paren:skip-whitespace + this (get-start-position) 'backward) + (paragraph-start-position first-para))) + (set-position + (let loop ([new-pos (get-start-position)]) + (if (let ([next (get-character new-pos)]) + (and (char-whitespace? next) + (not (char=? next #\newline)))) + (loop (add1 new-pos)) + new-pos))))) + (lambda () + (end-edit-sequence) + (when (< first-para end-para) + (end-busy-cursor)))))))) + + (define (tabify-all) (tabify-selection 0 (last-position))) + (define (insert-return) + (if (tabify-on-return?) + (begin + (begin-edit-sequence) + (insert #\newline) + (tabify (get-start-position)) + (set-position + (let loop ([new-pos (get-start-position)]) + (if (let ([next (get-character new-pos)]) + (and (char-whitespace? next) + (not (char=? next #\newline)))) + (loop (add1 new-pos)) + new-pos))) + (end-edit-sequence)) + (insert #\newline))) + + (define (calc-last-para last-pos) + (let ([last-para (position-paragraph last-pos #t)]) + (if (and (> last-pos 0) + (> last-para 0)) + (begin (split-snip last-pos) + (let ([snip (find-snip last-pos 'before)]) + (if (member 'hard-newline (send snip get-flags)) + (- last-para 1) + last-para))) + last-para))) + + (define comment-out-selection + (opt-lambda ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (begin-edit-sequence) + (let ([first-pos-is-first-para-pos? + (= (paragraph-start-position (position-paragraph start-pos)) + start-pos)]) + (let* ([first-para (position-paragraph start-pos)] + [last-para (calc-last-para end-pos)]) + (let para-loop ([curr-para first-para]) + (if (<= curr-para last-para) + (let ([first-on-para (paragraph-start-position curr-para)]) + (insert #\; first-on-para) + (para-loop (add1 curr-para)))))) + (when first-pos-is-first-para-pos? + (set-position + (paragraph-start-position (position-paragraph (get-start-position))) + (get-end-position)))) + (end-edit-sequence) + #t)) + + (define uncomment-selection + (opt-lambda ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (begin-edit-sequence) + (let* ([last-pos (last-position)] + [first-para (position-paragraph start-pos)] + [last-para (calc-last-para end-pos)]) + (let para-loop ([curr-para first-para]) + (if (<= curr-para last-para) + (let ([first-on-para + (paren:skip-whitespace + this + (paragraph-start-position curr-para) + 'forward)]) + (when (and (< first-on-para last-pos) + (char=? #\; (get-character first-on-para))) + (delete first-on-para (+ first-on-para 1))) + (para-loop (add1 curr-para)))))) + (end-edit-sequence) + #t)) + + [define get-forward-sexp + (lambda (start-pos) + (scheme-paren:forward-match + this start-pos + (last-position) + forward-cache))] + [define remove-sexp + (lambda (start-pos) + (let ([end-pos (get-forward-sexp start-pos)]) + (if end-pos + (kill 0 start-pos end-pos) + (bell)) + #t))] + [define forward-sexp + (lambda (start-pos) + (let ([end-pos (get-forward-sexp start-pos)]) + (if end-pos + (set-position end-pos) + (bell)) + #t))] + [define flash-forward-sexp + (lambda (start-pos) + (let ([end-pos (get-forward-sexp start-pos)]) + (if end-pos + (flash-on end-pos (add1 end-pos)) + (bell)) + #t))] + [define get-backward-sexp + (lambda (start-pos) + (let* ([limit (get-limit start-pos)] + [end-pos + (scheme-paren:backward-match + this start-pos limit backward-cache)] + [min-pos + (scheme-paren:backward-containing-sexp + this start-pos limit backward-cache)] + [ans + (if (and end-pos + (or (not min-pos) + (>= end-pos min-pos))) + end-pos + #f)]) + ans))] + [define flash-backward-sexp + (lambda (start-pos) + (let ([end-pos (get-backward-sexp start-pos)]) + (if end-pos + (flash-on end-pos (add1 end-pos)) + (bell)) + #t))] + [define backward-sexp + (lambda (start-pos) + (let ([end-pos (get-backward-sexp start-pos)]) + (if end-pos + (set-position end-pos) + (bell)) + #t))] + [define find-up-sexp + (lambda (start-pos) + (let* ([exp-pos + (scheme-paren:backward-containing-sexp + this start-pos + (get-limit start-pos) + backward-cache)] + [paren-pos ;; find the closest open paren from this pair, behind exp-pos + (lambda (paren-pair) + (find-string + (car paren-pair) + 'backward + exp-pos))]) + + (if (and exp-pos (> exp-pos 0)) + (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)]) (cond [(null? parens) null] [else @@ -712,123 +707,122 @@ (if pos (cons pos (loop (cdr parens))) (loop (cdr parens))))]))]) - (if (null? poss) ;; all finds failed - #f - (- (apply max poss) 1))) ;; subtract one to move outside the paren - #f)))] - [up-sexp - (lambda (start-pos) - (let ([exp-pos (find-up-sexp start-pos)]) - (if exp-pos - (set-position exp-pos) - (bell)) - #t))] - [find-down-sexp - (lambda (start-pos) - (let ([last (last-position)]) - (let loop ([pos start-pos]) - (let ([next-pos (scheme-paren:forward-match - this pos last - forward-cache)]) - (if (and next-pos (> next-pos pos)) - (let ([back-pos - (scheme-paren:backward-containing-sexp - this (sub1 next-pos) pos backward-cache)]) - (if (and back-pos - (> back-pos pos)) - back-pos - (loop next-pos))) - #f)))))] - [down-sexp - (lambda (start-pos) - (let ([pos (find-down-sexp start-pos)]) - (if pos - (set-position pos) - (bell)) - #t))] - [remove-parens-forward - (lambda (start-pos) - (let* ([pos (paren:skip-whitespace this start-pos 'forward)] - [first-char (get-character pos)] - [paren? (or (char=? first-char #\( ) - (char=? first-char #\[ ))] - [closer (if paren? - (scheme-paren:forward-match - this pos (last-position) - forward-cache))]) - (if (and paren? closer) - (begin (begin-edit-sequence) - (delete pos (add1 pos)) - (delete (- closer 2) (- closer 1)) - (end-edit-sequence)) - (bell)) - #t))]) - - (private - [select-text - (lambda (f forward?) - (let* ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (let-values ([(new-start new-end) - (if forward? - (values start-pos (f end-pos)) - (values (f start-pos) end-pos))]) - (if (and new-start new-end) - (set-position new-start new-end) - (bell)) - #t)))]) - (public - [select-forward-sexp (lambda () (select-text (lambda (x) (get-forward-sexp x)) #t))] - [select-backward-sexp (lambda () (select-text (lambda (x) (get-backward-sexp x)) #f))] - [select-up-sexp (lambda () (select-text (lambda (x) (find-up-sexp x)) #f))] - [select-down-sexp (lambda () (select-text (lambda (x) (find-down-sexp x)) #t))] - - [transpose-sexp - (lambda (pos) - (let ([start-1 (get-backward-sexp pos)]) - (if (not start-1) - (bell) - (let ([end-1 (get-forward-sexp start-1)]) - (if (not end-1) - (bell) - (let ([end-2 (get-forward-sexp end-1)]) - (if (not end-2) - (bell) - (let ([start-2 (get-backward-sexp end-2)]) - (if (or (not start-2) - (< start-2 end-1)) - (bell) - (let ([text-1 - (get-text start-1 end-1)] - [text-2 - (get-text start-2 end-2)]) - (begin-edit-sequence) - (insert text-1 start-2 end-2) - (insert text-2 start-1 end-1) - (set-position end-2) - (end-edit-sequence)))))))))))]) - (private-field - [tab-size 8]) - (public - [get-tab-size (lambda () tab-size)] - [set-tab-size (lambda (s) (set! tab-size s))]) - - (rename [super-get-keymaps get-keymaps]) - (override - [get-keymaps - (lambda () - (cons keymap (super-get-keymaps)))]) + (if (null? poss) ;; all finds failed + #f + (- (apply max poss) 1))) ;; subtract one to move outside the paren + #f)))] + [define up-sexp + (lambda (start-pos) + (let ([exp-pos (find-up-sexp start-pos)]) + (if exp-pos + (set-position exp-pos) + (bell)) + #t))] + [define find-down-sexp + (lambda (start-pos) + (let ([last (last-position)]) + (let loop ([pos start-pos]) + (let ([next-pos (scheme-paren:forward-match + this pos last + forward-cache)]) + (if (and next-pos (> next-pos pos)) + (let ([back-pos + (scheme-paren:backward-containing-sexp + this (sub1 next-pos) pos backward-cache)]) + (if (and back-pos + (> back-pos pos)) + back-pos + (loop next-pos))) + #f)))))] + [define down-sexp + (lambda (start-pos) + (let ([pos (find-down-sexp start-pos)]) + (if pos + (set-position pos) + (bell)) + #t))] + [define remove-parens-forward + (lambda (start-pos) + (let* ([pos (paren:skip-whitespace this start-pos 'forward)] + [first-char (get-character pos)] + [paren? (or (char=? first-char #\( ) + (char=? first-char #\[ ))] + [closer (if paren? + (scheme-paren:forward-match + this pos (last-position) + forward-cache))]) + (if (and paren? closer) + (begin (begin-edit-sequence) + (delete pos (add1 pos)) + (delete (- closer 2) (- closer 1)) + (end-edit-sequence)) + (bell)) + #t))] - (sequence - (apply super-init args) - - (highlight-parens #t) - (set-load-overwrites-styles #f) - (set-wordbreak-map wordbreak-map) - (set-tabs null tab-size #f) - (set-style-list style-list) - (set-styles-fixed #t)))) - + [define select-text + (lambda (f forward?) + (let* ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (let-values ([(new-start new-end) + (if forward? + (values start-pos (f end-pos)) + (values (f start-pos) end-pos))]) + (if (and new-start new-end) + (set-position new-start new-end) + (bell)) + #t)))] + (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp + transpose-sexp) + + [define select-forward-sexp (lambda () (select-text (lambda (x) (get-forward-sexp x)) #t))] + [define select-backward-sexp (lambda () (select-text (lambda (x) (get-backward-sexp x)) #f))] + [define select-up-sexp (lambda () (select-text (lambda (x) (find-up-sexp x)) #f))] + [define select-down-sexp (lambda () (select-text (lambda (x) (find-down-sexp x)) #t))] + + [define transpose-sexp + (lambda (pos) + (let ([start-1 (get-backward-sexp pos)]) + (if (not start-1) + (bell) + (let ([end-1 (get-forward-sexp start-1)]) + (if (not end-1) + (bell) + (let ([end-2 (get-forward-sexp end-1)]) + (if (not end-2) + (bell) + (let ([start-2 (get-backward-sexp end-2)]) + (if (or (not start-2) + (< start-2 end-1)) + (bell) + (let ([text-1 + (get-text start-1 end-1)] + [text-2 + (get-text start-2 end-2)]) + (begin-edit-sequence) + (insert text-1 start-2 end-2) + (insert text-2 start-1 end-1) + (set-position end-2) + (end-edit-sequence)))))))))))] + [define tab-size 8] + (public get-tab-size set-tab-size) + [define get-tab-size (lambda () tab-size)] + [define set-tab-size (lambda (s) (set! tab-size s))] + + (rename [super-get-keymaps get-keymaps]) + (override get-keymaps) + [define get-keymaps + (lambda () + (cons keymap (super-get-keymaps)))] + + (super-instantiate ()) + + (highlight-parens #t) + (set-load-overwrites-styles #f) + (set-wordbreak-map wordbreak-map) + (set-tabs null tab-size #f) + (set-style-list style-list) + (set-styles-fixed #t))) + (define -text% (text-mixin text:info%)) (define setup-keymap diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index e317ff89..ca9ecf05 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -131,18 +131,21 @@ (define-signature framework:text^ (basic<%> + hide/selection<%> searching<%> return<%> info<%> clever-file-format<%> basic-mixin + hide/selection-mixin searching-mixin return-mixin info-mixin clever-file-format-mixin basic% + hide/selection% keymap% return% autowrap% diff --git a/collects/framework/private/standard-menus-items.ss b/collects/framework/private/standard-menus-items.ss index 3d5e694a..27eb2d2f 100644 --- a/collects/framework/private/standard-menus-items.ss +++ b/collects/framework/private/standard-menus-items.ss @@ -1,36 +1,23 @@ (module standard-menus-items mzscheme (provide - ;(struct generic (name initializer)) - generic? generic-name generic-initializer + (struct generic (name initializer)) - ;(generic/docs (documentation)) - generic/docs? generic/docs-documentation + (struct generic/docs (documentation)) - ;(struct generic-override ()) - generic-override? - ;(struct generic-method ()) - generic-method? - ;(struct generic-private-field ()) - generic-private-field? + (struct generic-override ()) + (struct generic-method ()) + (struct generic-private-field ()) - ;(struct menu-item (menu-name)) - menu-item-menu-name + (struct menu-item (menu-name)) menu-name->get-menu-name ;; : menu-item -> symbol - ;(struct before/after (name procedure)) - ;(struct before ()) - ;(struct after ()) - before? after? - before/after-name before/after-procedure + (struct before/after (name procedure)) + (struct before ()) + (struct after ()) - ;(struct between (before after procedure)) - between? - between-before between-after between-procedure + (struct between (before after procedure)) - ;(struct an-item (item-name help-string proc key menu-string-before menu-string-after on-demand)) - an-item? - an-item-item-name an-item-help-string an-item-proc an-item-key - an-item-menu-string-before an-item-menu-string-after an-item-on-demand + (struct an-item (item-name help-string proc key menu-string-before menu-string-after on-demand)) ;; an-item -> symbol ;; calcualates the names of various identifiers associated with the item. diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index b69700e8..94041e1f 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -25,7 +25,7 @@ (define-struct range (start end b/w-bitmap color caret-space?)) (define-struct rectangle (left top right bottom b/w-bitmap color)) - + ;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap, ;; unless matthew makes it primitive @@ -36,9 +36,12 @@ set-styles-fixed move/copy-to-edit initial-autowrap-bitmap)) + + (define highlight-pen (make-object pen% "BLACK" 0 'solid)) + (define highlight-brush (make-object brush% "black" 'solid)) (define basic-mixin - (mixin (editor:basic<%> (class->interface text%)) (basic<%>) args + (mixin (editor:basic<%> (class->interface text%)) (basic<%>) (inherit get-canvases get-admin split-snip get-snip-position begin-edit-sequence end-edit-sequence set-autowrap-bitmap @@ -46,89 +49,85 @@ set-file-format get-file-format get-style-list is-modified? change-style set-modified position-location get-extent) - - (private-field - [b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)] - [range-rectangles null] - [ranges null] - [pen (make-object pen% "BLACK" 0 'solid)] - [brush (make-object brush% "black" 'solid)]) - (private - [invalidate-rectangles - (lambda (rectangles) - (let-values - ([(min-left max-right) - (let loop ([left #f] - [right #f] - [canvases (get-canvases)]) - (cond - [(null? canvases) - (values left right)] - [else - (let-values ([(this-left this-right) - (send (car canvases) - call-as-primary-owner - (lambda () - (send (get-admin) get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))))]) - (if (and left right) - (loop (min this-left left) - (max this-right right) - (cdr canvases)) - (loop this-left - this-right - (cdr canvases))))]))]) - (when (and min-left max-right) - (let loop ([left #f] - [top #f] - [right #f] - [bottom #f] - [rectangles rectangles]) - (cond - [(null? rectangles) - (when left - (let ([width (- right left)] - [height (- bottom top)]) - (when (and (> width 0) - (> height 0)) - (invalidate-bitmap-cache left top width height))))] - [else (let* ([r (car rectangles)] - - [rleft (rectangle-left r)] - [rright (rectangle-right r)] - [rtop (rectangle-top r)] - [rbottom (rectangle-bottom r)] - - [this-left (if (number? rleft) - rleft - min-left)] - [this-right (if (number? rright) - rright - max-right)] - [this-bottom rbottom] - [this-top rtop]) - (if (and left top right bottom) - (loop (min this-left left) - (min this-top top) - (max this-right right) - (max this-bottom bottom) - (cdr rectangles)) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles))))])))))] + + (define range-rectangles null) + (define ranges null) + + (define (invalidate-rectangles rectangles) + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)]) + (let-values ([(min-left max-right) + (let loop ([left #f] + [right #f] + [canvases (get-canvases)]) + (cond + [(null? canvases) + (values left right)] + [else + (let-values ([(this-left this-right) + (send (car canvases) + call-as-primary-owner + (lambda () + (send (get-admin) get-view b1 b2 b3 b4) + (let* ([this-left (unbox b1)] + [this-width (unbox b3)] + [this-right (+ this-left this-width)]) + (values this-left + this-right))))]) + (if (and left right) + (loop (min this-left left) + (max this-right right) + (cdr canvases)) + (loop this-left + this-right + (cdr canvases))))]))]) + (when (and min-left max-right) + (let loop ([left #f] + [top #f] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (when left + (let ([width (- right left)] + [height (- bottom top)]) + (when (and (> width 0) + (> height 0)) + (invalidate-bitmap-cache left top width height))))] + [else (let* ([r (car rectangles)] + + [rleft (rectangle-left r)] + [rright (rectangle-right r)] + [rtop (rectangle-top r)] + [rbottom (rectangle-bottom r)] + + [this-left (if (number? rleft) + rleft + min-left)] + [this-right (if (number? rright) + rright + max-right)] + [this-bottom rbottom] + [this-top rtop]) + (if (and left top right bottom) + (loop (min this-left left) + (min this-top top) + (max this-right right) + (max this-bottom bottom) + (cdr rectangles)) + (loop this-left + this-top + this-right + this-bottom + (cdr rectangles))))])))))) - [recompute-range-rectangles - (lambda () - (let ([new-rectangles + (define (recompute-range-rectangles) + (let* ([b1 (box 0)] + [b2 (box 0)] + [new-rectangles (lambda (range) (let* ([start (range-start range)] [end (range-end range)] @@ -187,201 +186,197 @@ b/w-bitmap color))]))))] [old-rectangles range-rectangles]) - - (set! range-rectangles - (foldl (lambda (x l) (append (new-rectangles x) l)) - null ranges))))]) - (public - ;; the bitmap is used in b/w and the color is used in color. - [highlight-range - (opt-lambda (start end color bitmap [caret-space? #f] [priority 'low]) - (unless (let ([exact-pos-int? - (lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))]) - (and (exact-pos-int? start) - (exact-pos-int? end))) - (error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e" - start end)) - (unless (or (eq? priority 'high) (eq? priority 'low)) - (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e" - priority)) - (let ([l (make-range start end bitmap color caret-space?)]) - (invalidate-rectangles range-rectangles) - (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))) - (recompute-range-rectangles) - (invalidate-rectangles range-rectangles) - (lambda () - (let ([old-rectangles range-rectangles]) - (set! ranges - (let loop ([r ranges]) - (cond - [(null? r) r] - [else (if (eq? (car r) l) - (cdr r) - (cons (car r) (loop (cdr r))))]))) - (recompute-range-rectangles) - (invalidate-rectangles old-rectangles)))))]) + + (set! range-rectangles + (foldl (lambda (x l) (append (new-rectangles x) l)) + null ranges)))) + + (public highlight-range) + (define highlight-range + (opt-lambda (start end color bitmap [caret-space? #f] [priority 'low]) + (unless (let ([exact-pos-int? + (lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))]) + (and (exact-pos-int? start) + (exact-pos-int? end))) + (error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e" + start end)) + (unless (or (eq? priority 'high) (eq? priority 'low)) + (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e" + priority)) + (let ([l (make-range start end bitmap color caret-space?)]) + (invalidate-rectangles range-rectangles) + (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))) + (recompute-range-rectangles) + (invalidate-rectangles range-rectangles) + (lambda () + (let ([old-rectangles range-rectangles]) + (set! ranges + (let loop ([r ranges]) + (cond + [(null? r) r] + [else (if (eq? (car r) l) + (cdr r) + (cons (car r) (loop (cdr r))))]))) + (recompute-range-rectangles) + (invalidate-rectangles old-rectangles)))))) (rename [super-on-paint on-paint]) - (override - [on-paint - (lambda (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) - (for-each - (lambda (rectangle) - (let-values ([(view-x view-y view-width view-height) - (begin - (send (get-admin) get-view b1 b2 b3 b4) - (values (unbox b1) - (unbox b2) - (unbox b3) - (unbox b4)))]) - (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [b/w-bitmap (rectangle-b/w-bitmap rectangle)] - [color (let* ([rc (rectangle-color rectangle)] - [tmpc (make-object color% 0 0 0)]) - (if rc - (begin (send dc try-color rc tmpc) - (if (<= (color-model:rgb-color-distance - (send rc red) - (send rc green) - (send rc blue) - (send tmpc red) - (send tmpc green) - (send tmpc blue)) - 18) - rc - #f)) - rc))] - [first-number (lambda (x y) (if (number? x) x y))] - [left (max left-margin (first-number (rectangle-left rectangle) view-x))] - [top (max top-margin (rectangle-top rectangle))] - [right (min right-margin - (if (number? (rectangle-right rectangle)) - (rectangle-right rectangle) - (+ view-x view-width)))] - [bottom (min bottom-margin (rectangle-bottom rectangle))] - [width (max 0 (- right left))] - [height (max 0 (- bottom top))]) - (let/ec k - (cond - [(and before color) - (send pen set-color color) - (send brush set-color color)] - [(and (not before) (not color) b/w-bitmap) - (send pen set-stipple b/w-bitmap) - (send brush set-stipple b/w-bitmap)] - [else (k (void))]) - (send dc set-pen pen) - (send dc set-brush brush) - (send dc draw-rectangle - (+ left dx) - (+ top dy) - width - height) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))) - range-rectangles))]) + (override on-paint) + (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) + (recompute-range-rectangles) + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)]) + (for-each + (lambda (rectangle) + (let-values ([(view-x view-y view-width view-height) + (begin + (send (get-admin) get-view b1 b2 b3 b4) + (values (unbox b1) + (unbox b2) + (unbox b3) + (unbox b4)))]) + (let* ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)] + [b/w-bitmap (rectangle-b/w-bitmap rectangle)] + [color (let* ([rc (rectangle-color rectangle)] + [tmpc (make-object color% 0 0 0)]) + (if rc + (begin (send dc try-color rc tmpc) + (if (<= (color-model:rgb-color-distance + (send rc red) + (send rc green) + (send rc blue) + (send tmpc red) + (send tmpc green) + (send tmpc blue)) + 18) + rc + #f)) + rc))] + [first-number (lambda (x y) (if (number? x) x y))] + [left (max left-margin (first-number (rectangle-left rectangle) view-x))] + [top (max top-margin (rectangle-top rectangle))] + [right (min right-margin + (if (number? (rectangle-right rectangle)) + (rectangle-right rectangle) + (+ view-x view-width)))] + [bottom (min bottom-margin (rectangle-bottom rectangle))] + [width (max 0 (- right left))] + [height (max 0 (- bottom top))]) + (let/ec k + (cond + [(and before color) + (send highlight-pen set-color color) + (send highlight-brush set-color color)] + [(and (not before) (not color) b/w-bitmap) + (send highlight-pen set-stipple b/w-bitmap) + (send highlight-brush set-stipple b/w-bitmap)] + [else (k (void))]) + (send dc set-pen highlight-pen) + (send dc set-brush highlight-brush) + (send dc draw-rectangle (+ left dx) (+ top dy) width height) + (send dc set-pen old-pen) + (send dc set-brush old-brush))))) + range-rectangles))) + + (define styles-fixed? #f) + (define styles-fixed-edit-modified? #f) + (public get-styles-fixed set-styles-fixed) + (define (get-styles-fixed) styles-fixed?) + (define (set-styles-fixed b) (set! styles-fixed? b)) - (private-field - [styles-fixed? #f] - [styles-fixed-edit-modified? #f]) - (public - [get-styles-fixed (lambda () styles-fixed?)] - [set-styles-fixed (lambda (b) (set! styles-fixed? b))]) (rename [super-on-change-style on-change-style] [super-after-change-style after-change-style] [super-on-insert on-insert] [super-after-insert after-insert]) - (override - [on-change-style - (lambda (start len) - (when styles-fixed? - (set! styles-fixed-edit-modified? (is-modified?))) - (super-on-change-style start len))] - [on-insert - (lambda (start len) - (begin-edit-sequence) - (super-on-insert start len))] - [after-insert - (lambda (start len) - (when styles-fixed? - (change-style (send (get-style-list) find-named-style "Standard") - start - (+ start len))) - (super-after-insert start len) - (end-edit-sequence))] - [after-change-style - (lambda (start len) - (super-after-change-style start len) - (when styles-fixed? - (set-modified styles-fixed-edit-modified?)))]) + (override on-change-style on-insert after-insert after-change-style) + (define (on-change-style start len) + (when styles-fixed? + (set! styles-fixed-edit-modified? (is-modified?))) + (super-on-change-style start len)) + (define (on-insert start len) + (begin-edit-sequence) + (super-on-insert start len)) + (define (after-insert start len) + (when styles-fixed? + (change-style (send (get-style-list) find-named-style "Standard") + start + (+ start len))) + (super-after-insert start len) + (end-edit-sequence)) + (define (after-change-style start len) + (super-after-change-style start len) + (when styles-fixed? + (set-modified styles-fixed-edit-modified?))) - (public - [move/copy-to-edit - (lambda (dest-edit start end dest-position) - (split-snip start) - (split-snip end) - (let loop ([snip (find-snip end 'before)]) - (cond - [(or (not snip) (< (get-snip-position snip) start)) - (void)] - [else - (let ([prev (send snip previous)] - [released/copied (if (send snip release-from-owner) - snip - (let* ([copy (send snip copy)] - [snip-start (get-snip-position snip)] - [snip-end (+ snip-start (send snip get-count))]) - (delete snip-start snip-end) - snip))]) - (send dest-edit insert released/copied dest-position dest-position) - (loop prev))])))]) + (public move/copy-to-edit) + (define (move/copy-to-edit dest-edit start end dest-position) + (split-snip start) + (split-snip end) + (let loop ([snip (find-snip end 'before)]) + (cond + [(or (not snip) (< (get-snip-position snip) start)) + (void)] + [else + (let ([prev (send snip previous)] + [released/copied (if (send snip release-from-owner) + snip + (let* ([copy (send snip copy)] + [snip-start (get-snip-position snip)] + [snip-end (+ snip-start (send snip get-count))]) + (delete snip-start snip-end) + snip))]) + (send dest-edit insert released/copied dest-position dest-position) + (loop prev))]))) - (public - [initial-autowrap-bitmap (lambda () (icon:get-autowrap-bitmap))]) + (public initial-autowrap-bitmap) + (define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap)) - (sequence - (apply super-init args) - (set-autowrap-bitmap (initial-autowrap-bitmap))))) + (super-instantiate ()) + (set-autowrap-bitmap (initial-autowrap-bitmap)))) + + (define hide/selection<%> (interface (basic<%>))) + (define hide/selection-mixin + (mixin (basic<%>) (hide/selection<%>) + (override after-set-position) + (inherit get-start-position get-end-position hide-caret) + (define (after-set-position) + (hide-caret (= (get-start-position) (get-end-position)))) + (super-instantiate ()))) (define searching<%> (interface (editor:keymap<%> basic<%>))) (define searching-mixin - (mixin (editor:keymap<%> basic<%>) (searching<%>) args + (mixin (editor:keymap<%> basic<%>) (searching<%>) (rename [super-get-keymaps get-keymaps]) - (override - [get-keymaps - (lambda () - (cons (keymap:get-search) (super-get-keymaps)))]) - - (sequence - (apply super-init args)))) - + (override get-keymaps) + (define (get-keymaps) + (cons (keymap:get-search) (super-get-keymaps))) + (super-instantiate ()))) + (define return<%> (interface ((class->interface text%)))) - (define return-mixin - (mixin ((class->interface text%)) (return<%>) (_return . args) + (mixin ((class->interface text%)) (return<%>) + (init-field return) (rename [super-on-local-char on-local-char]) - (private-field [return _return]) - (override - [on-local-char - (lambda (key) - (let ([cr-code #\return] - [lf-code #\newline] - [code (send key get-key-code)]) - (or (and (char? code) - (or (char=? lf-code code) - (char=? cr-code code)) - (return)) - (super-on-local-char key))))]) - (sequence - (apply super-init args)))) + (override on-local-char) + (define (on-local-char key) + (let ([cr-code #\return] + [lf-code #\newline] + [code (send key get-key-code)]) + (or (and (char? code) + (or (char=? lf-code code) + (char=? cr-code code)) + (return)) + (super-on-local-char key)))) + (super-instantiate ()))) (define info<%> (interface (basic<%>))) (define info-mixin - (mixin (editor:keymap<%> basic<%>) (info<%>) args + (mixin (editor:keymap<%> basic<%>) (info<%>) (inherit get-start-position get-end-position get-canvas run-after-edit-sequence) (rename [super-after-set-position after-set-position] @@ -391,92 +386,81 @@ [super-after-delete after-delete] [super-set-overwrite-mode set-overwrite-mode] [super-set-anchor set-anchor]) - (private - [enqueue-for-frame - (lambda (call-method tag) - (run-after-edit-sequence - (rec from-enqueue-for-frame - (lambda () - (let ([canvas (get-canvas)]) - (when canvas - (let ([frame (send canvas get-top-level-window)]) - (when (is-a? frame frame:text-info<%>) - (call-method frame))))))) - tag))]) - (override - [set-anchor - (lambda (x) - (super-set-anchor x) - (enqueue-for-frame - (lambda (x) (send x anchor-status-changed)) - 'framework:anchor-status-changed))] - [set-overwrite-mode - (lambda (x) - (super-set-overwrite-mode x) - (enqueue-for-frame - (lambda (x) (send x overwrite-status-changed)) - 'framework:overwrite-status-changed))] - [after-set-position - (lambda () - (super-after-set-position) - (enqueue-for-frame - (lambda (x) (send x editor-position-changed)) - 'framework:editor-position-changed))] - [after-insert - (lambda (start len) - (super-after-insert start len) - (enqueue-for-frame - (lambda (x) (send x editor-position-changed)) - 'framework:editor-position-changed))] - [after-delete - (lambda (start len) - (super-after-delete start len) - (enqueue-for-frame - (lambda (x) (send x editor-position-changed)) - 'framework:editor-position-changed))]) - (sequence - (apply super-init args)))) + (define (enqueue-for-frame call-method tag) + (run-after-edit-sequence + (rec from-enqueue-for-frame + (lambda () + (let ([canvas (get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame frame:text-info<%>) + (call-method frame))))))) + tag)) + (override set-anchor set-overwrite-mode after-set-position after-insert after-delete) + (define (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) + (super-set-overwrite-mode x) + (enqueue-for-frame + (lambda (x) (send x overwrite-status-changed)) + 'framework:overwrite-status-changed)) + (define (after-set-position) + (super-after-set-position) + (enqueue-for-frame + (lambda (x) (send x editor-position-changed)) + 'framework:editor-position-changed)) + (define (after-insert start len) + (super-after-insert start len) + (enqueue-for-frame + (lambda (x) (send x editor-position-changed)) + 'framework:editor-position-changed)) + (define (after-delete start len) + (super-after-delete start len) + (enqueue-for-frame + (lambda (x) (send x editor-position-changed)) + 'framework:editor-position-changed)) + (super-instantiate ()))) (define clever-file-format<%> (interface ((class->interface text%)))) (define clever-file-format-mixin - (mixin ((class->interface text%)) (clever-file-format<%>) args + (mixin ((class->interface text%)) (clever-file-format<%>) (inherit get-file-format set-file-format find-first-snip) (rename [super-on-save-file on-save-file]) - (private - [all-string-snips - (lambda () - (let loop ([s (find-first-snip)]) - (cond - [(not s) #t] - [(is-a? s string-snip%) - (loop (send s next))] - [else #f])))]) - (override - [on-save-file - (lambda (name format) - (let ([all-strings? (all-string-snips)]) - (cond - [(and all-strings? - (or (eq? format 'same) (eq? format 'copy)) - (eq? 'standard (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - "Save this file as plain text?" "Yes" "No"))) - (set-file-format 'text)] - [(and (not all-strings?) - (or (eq? format 'same) (eq? format 'copy)) - (eq? 'text (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - "Save this file in drscheme-specific non-text format?" "Yes" "No"))) - (set-file-format 'standard)] - [else (void)])) - (super-on-save-file name format))]) - (sequence - (apply super-init args)))) + (define (all-string-snips) + (let loop ([s (find-first-snip)]) + (cond + [(not s) #t] + [(is-a? s string-snip%) + (loop (send s next))] + [else #f]))) + (override on-save-file) + (define (on-save-file name format) + (let ([all-strings? (all-string-snips)]) + (cond + [(and all-strings? + (or (eq? format 'same) (eq? format 'copy)) + (eq? 'standard (get-file-format)) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice + "Save this file as plain text?" "Yes" "No"))) + (set-file-format 'text)] + [(and (not all-strings?) + (or (eq? format 'same) (eq? format 'copy)) + (eq? 'text (get-file-format)) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice + "Save this file in drscheme-specific non-text format?" "Yes" "No"))) + (set-file-format 'standard)] + [else (void)])) + (super-on-save-file name format)) + (super-instantiate ()))) (define basic% (basic-mixin (editor:basic-mixin text%))) + (define hide/selection% (hide/selection-mixin basic%)) (define -keymap% (editor:keymap-mixin basic%)) (define return% (return-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%)) diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 3c8c927b..20189949 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -12,7 +12,8 @@ (define (splash filename title width-default) (let/ec k (letrec-values - ([(no-splash) (lambda () (k void void void))] + ([(splash-eventspace) (make-eventspace)] + [(no-splash) (lambda () (k #f #f splash-eventspace void void void))] [(funny?) (let ([date (seconds->date (current-seconds))]) (and (= (date-day date) 25) (= (date-month date) 12)))] @@ -116,7 +117,6 @@ (when quit-on-close? (exit)))]) (sequence (super-init title)))] - [(splash-eventspace) (make-eventspace)] [(frame) (parameterize ([current-eventspace splash-eventspace]) (make-object splash-frame% title))] [(_0) (send frame accept-drop-files #t)] @@ -133,7 +133,7 @@ [else 'xpm]))))] [(bitmap) (make-object bitmap% filename bitmap-flag)] [(_2) (unless (send bitmap ok?) - (fprintf (current-error-port) "WARNING: bad bitmap ~s" filename) + (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" filename) (no-splash))] [(splash-canvas%) (class100 canvas% args