diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss index 70744bf2..cc5837ef 100644 --- a/collects/framework/editor.ss +++ b/collects/framework/editor.ss @@ -23,15 +23,6 @@ (define basic-mixin (mixin (editor<%>) (basic<%>) args - -; (inherit copy-self-to) -; (override -; [copy-self -; (lambda () -; (let ([editor (make-object (object-interface this))]) -; (copy-self-to editor) -; editor))]) - (inherit get-filename save-file refresh-delayed? get-canvas @@ -53,26 +44,34 @@ (private [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))]) + [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 void] [get-top-level-window (lambda () - (let ([c (get-canvas)]) - (and c - (send c get-top-level-window))))]) + (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)]) + (loop (send snip-admin get-editor)))] + [(send text get-canvas) => (lambda (canvas) + (send canvas get-top-level-window))] + [else + #f]))))]) (public [editing-this-file? (lambda () #f)]) @@ -97,11 +96,24 @@ "expected second argument to be a symbol, got: ~s~n" sym)) (if (refresh-delayed?) - (cond - [(symbol? sym) - (hash-table-put! edit-sequence-ht sym t)] - [else (set! edit-sequence-queue - (cons t edit-sequence-queue))]) + (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 + [(not snip-admin) + (t)] ;; refresh-delayed? is always #t when there is no admin. + [(is-a? snip-admin editor-snip-editor-admin<%>) + (send (send (send (send snip-admin get-snip) get-admin) get-editor) + run-after-edit-sequence t sym)] + [else + (message-box "run-after-edit-sequence error" + (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 @@ -112,64 +124,62 @@ 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]) + [super-after-edit-sequence after-edit-sequence] + [super-on-edit-sequence on-edit-sequence]) (override - [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)] - ;; assume that any non-media-snip - ;; administrator doesn't have embedded edits. - [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)]))))]) - + [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)]))))]) + (rename [super-lock lock]) (private [is-locked? #f]) (public [locked? (lambda () is-locked?)]) (override - [lock - (lambda (x) - (set! is-locked? x) - (super-lock x))] - [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%))]))]) + [lock + (lambda (x) + (set! is-locked? x) + (super-lock x))] + [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)))]) + [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)))]) (sequence diff --git a/collects/framework/guiutils.ss b/collects/framework/guiutils.ss index 797cf6be..7dc2508c 100644 --- a/collects/framework/guiutils.ss +++ b/collects/framework/guiutils.ss @@ -196,7 +196,7 @@ [(not snip) (set! get-next (lambda () eof)) eof] - [(<= end (unbox pos-box)) + [(not (<= (+ (unbox pos-box) (send snip get-count)) end)) (set! get-next (lambda () eof)) eof] [(is-a? snip sexp-snip<%>) diff --git a/collects/framework/keymap.ss b/collects/framework/keymap.ss index 58619ff2..0a9d3ee8 100644 --- a/collects/framework/keymap.ss +++ b/collects/framework/keymap.ss @@ -24,6 +24,41 @@ (lambda (edit event) (bell))] + [up-out-of-editor-snip + (lambda (text event) + (let ([editor-admin (send text get-admin)]) + (when (is-a? editor-admin editor-snip-editor-admin<%>) + (let* ([snip (send editor-admin get-snip)] + [snip-admin (send snip get-admin)]) + (when snip-admin + (let ([editor (send snip-admin get-editor)]) + (when (is-a? editor text%) + (let ([new-pos (+ (send editor get-snip-position snip) + (if (= 0 (send text get-end-position)) + 0 + (send snip get-count)))]) + (send editor set-position new-pos new-pos)) + (send editor set-caret-owner #f 'display))))))) + #t)] + + [down-into-editor-snip + (lambda (dir get-pos) + (lambda (text event) + (when (= (send text get-start-position) + (send text get-end-position)) + (let* ([pos (send text get-start-position)] + [snip (send text find-snip pos dir)]) + (when (and snip + (is-a? snip editor-snip%)) + (let ([embedded-editor (send snip get-editor)]) + (when (is-a? embedded-editor text%) + (send embedded-editor set-position (get-pos embedded-editor))) + (send text set-caret-owner snip 'display))))) + #t))] + + [right-into-editor-snip (down-into-editor-snip 'after-or-none (lambda (x) 0))] + [left-into-editor-snip (down-into-editor-snip 'before-or-none (lambda (x) (send x last-position)))] + [toggle-anchor (lambda (edit event) (send edit set-anchor @@ -554,6 +589,10 @@ (add "flash-paren-match" flash-paren-match) + (add "left-into-editor-snip" left-into-editor-snip) + (add "right-into-editor-snip" right-into-editor-snip) + (add "up-out-of-editor-snip" up-out-of-editor-snip) + (add "toggle-anchor" toggle-anchor) (add "center-view-on-line" center-view-on-line) (add "collapse-space" collapse-space) @@ -729,6 +768,10 @@ (map "c:space" "toggle-anchor") + (map-meta "c:left" "left-into-editor-snip") + (map-meta "c:right" "right-into-editor-snip") + (map-meta "c:up" "up-out-of-editor-snip") + (map "insert" "toggle-overwrite") (map-meta "o" "toggle-overwrite") diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index 32bced8d..685610bd 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -175,9 +175,8 @@ (with-handlers ([(lambda (x) #t) (lambda (exn) (message-box - (format "Error saving preferences~n~a" - (exn-message exn)) - "Error saving preferences"))]) + "Error saving preferences" + (exn-message exn)))]) (call-with-output-file preferences-filename (lambda (p) (mzlib:pretty-print:pretty-print diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss index 41dcdb39..a2fa9cb7 100644 --- a/collects/tests/framework/mem.ss +++ b/collects/tests/framework/mem.ss @@ -2,7 +2,6 @@ (send-sexp-to-mred '(define mem-boxes null)) (define mem-count 10) -(define mem-cutoff 1) (define (test-allocate tag open close) (send-sexp-to-mred @@ -31,18 +30,23 @@ (lambda (boxl) (let* ([tag (first boxl)] [boxes (second boxl)] - [res + [calc-results (lambda () (foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n)) 0 boxes))]) - (unless (<= (calc-results) ,mem-cutoff) + (when (> (calc-results) 0) + (collect-garbage) + (collect-garbage) + (collect-garbage) + (collect-garbage) + (collect-garbage) (collect-garbage)) (let ([res (calc-results)]) - (when (<= res ,mem-cutoff) + (when (> res 0) (set! anything? #t) (make-object message% (format "~a: ~a of ~a~n" tag res ,mem-count) f))))) - mem-boxes) + (reverse mem-boxes)) (cond [anything? (make-object button% "Close" f (lambda x (send f show #f)))] [else (make-object button% "NOTHING!" f (lambda x (send f show #f)))]) @@ -64,6 +68,33 @@ '(lambda (f) (send f show #f))) +(define (test-editor-allocate object-name) + (test-allocate (symbol->string object-name) + `(lambda () (make-object ,object-name)) + '(lambda (e) (send e on-close)))) + +(test-editor-allocate 'text:basic%) +(test-editor-allocate 'text:keymap%) +(test-editor-allocate 'text:autowrap%) +(test-editor-allocate 'text:file%) +(test-editor-allocate 'text:clever-file-format%) +(test-editor-allocate 'text:backup-autosave%) +(test-editor-allocate 'text:searching%) +(test-editor-allocate 'text:info%) + +(test-editor-allocate 'pasteboard:basic%) +(test-editor-allocate 'pasteboard:keymap%) +(test-editor-allocate 'pasteboard:file%) +(test-editor-allocate 'pasteboard:backup-autosave%) +(test-editor-allocate 'pasteboard:info%) + +(test-editor-allocate 'scheme:text%) + +(test-allocate "text:return%" + '(lambda () (make-object text:return% void)) + '(lambda (t) (void))) + + (test-frame-allocate "frame:basic%" 'frame:basic%) (test-frame-allocate "frame:standard-menus%" 'frame:standard-menus%) (test-frame-allocate "frame:text%" 'frame:text%)