diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss index 1e665a0c..3cf124bb 100644 --- a/collects/mred/edit.ss +++ b/collects/mred/edit.ss @@ -35,8 +35,14 @@ (lambda (snip%) (class snip% args (inherit set-style) + (public [edit% media-edit%]) (sequence - (apply super-init args) + (cond + [(null? args) + (super-init (make-object edit%))] + [(null? (car args)) + (apply super-init (make-object edit%) (cdr args))] + [else (apply super-init args)]) (set-style std))))))) (define media-snip% (make-snip% wx:media-snip%)) @@ -51,7 +57,6 @@ (rename [super-set-modified set-modified] [super-on-save-file on-save-file] [super-on-focus on-focus] - [super-set-max-width set-max-width] [super-lock lock]) (public @@ -76,10 +81,6 @@ [else (get-pasteboard-snip)]))]) (public - [set-max-width - (lambda (x) - (mred:debug:printf 'rewrap "rewrap: set-max-width: ~a" x) - (super-set-max-width x))] [get-file (lambda (d) (let ([v (mred:finder:get-file d)]) (if v @@ -89,42 +90,6 @@ (if v v '())))] - - [auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)] - [set-auto-set-wrap - (lambda (v) - (mred:debug:printf 'rewrap - "rewrap: set-auto-set-wrap: ~a (canvases ~a)" - v canvases) - (set! auto-set-wrap? v) - (for-each (lambda (c) (send c resize-edit)) canvases))] - - [rewrap - (lambda () - (if auto-set-wrap? - (let* ([current-width (get-max-width)] - [w-box (box 0)] - [new-width - (mzlib:function:foldl - (lambda (canvas sofar) - (send canvas call-as-primary-owner - (lambda () - (send (get-admin) - get-view null null - w-box (box 0)))) - (max (unbox w-box) sofar)) - 0 - canvases)]) - (mred:debug:printf 'rewrap "rewrap: new-width ~a current-width ~a" - new-width current-width) - (when (and (not (= current-width new-width)) - (< 0 new-width)) - (set-max-width new-width) - (mred:debug:printf 'rewrap "rewrap: attempted to wrap to: ~a actually wrapped to ~a" - new-width (get-max-width)))) - (begin - (mred:debug:printf 'rewrap "rewrap: wrapping to -1") - (set-max-width -1))))] [mode #f] [set-mode-direct (lambda (v) (set! mode v))] [set-mode @@ -133,141 +98,41 @@ (sequence (apply super-init args))))) - (define make-edit% + (define make-pasteboard% make-std-buffer%) + + (define make-media-edit% (lambda (super%) - (class (make-std-buffer% super%) args - (inherit mode set-mode-direct canvases get-file-format - set-filename find-string get-snip-position - change-style save-file get-admin - invalidate-bitmap-cache split-snip + (class super% args + (inherit canvases get-max-width get-admin split-snip get-snip-position + delete find-snip set-filename invalidate-bitmap-cache begin-edit-sequence end-edit-sequence - flash-on get-keymap get-start-position - get-end-position last-position - on-default-char on-default-event - set-file-format get-style-list - set-autowrap-bitmap delete - get-snip-location find-snip get-max-width - modified? set-modified - lock get-filename) + set-autowrap-bitmap get-keymap mode set-mode-direct + set-file-format get-file-format + get-style-list modified? change-style set-modified) (rename [super-on-focus on-focus] - [super-on-paint on-paint] [super-on-local-event on-local-event] - [super-on-local-char on-local-char] - - [super-on-save-file on-save-file] - [super-after-save-file after-save-file] [super-after-set-position after-set-position] - + [super-on-edit-sequence on-edit-sequence] [super-on-change-style on-change-style] [super-on-insert on-insert] [super-on-delete on-delete] [super-on-set-size-constraint on-set-size-constraint] - - [super-after-load-file after-load-file] - [super-load-file load-file] [super-after-edit-sequence after-edit-sequence] [super-after-change-style after-change-style] [super-after-insert after-insert] [super-after-delete after-delete] - [super-after-set-size-constraint after-set-size-constraint]) + [super-after-set-size-constraint after-set-size-constraint] - (private - [styles-fixed-edit-modified? #f] - [restore-file-format void]) + [super-set-max-width set-max-width] + [super-load-file load-file] + [super-on-paint on-paint]) + (private [styles-fixed-edit-modified? #f]) (public - [move/copy-to-edit - (lambda (dest-edit start end dest-position) - (let ([insert-edit (ivar dest-edit insert)]) - (split-snip start) - (split-snip end) - (let loop ([snip (find-snip end wx:const-snip-before)]) - (cond - [(or (null? 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))]) - '(wx:message-box (format "before: ~a" (eq? snip released/copied))) - (insert-edit released/copied dest-position dest-position) - '(wx:message-box (format "after: ~a" (eq? snip released/copied))) - (loop prev))]))))]) - - (public - [on-save-file - (let ([has-non-text-snips - (lambda () - (let loop ([s (find-snip 0 wx:const-snip-after)]) - (cond - [(null? s) #f] - [(is-a? s wx:text-snip%) - (loop (send s next))] - [else #t])))]) - (lambda (name format) - (when (and (or (= format wx:const-media-ff-same) - (= format wx:const-media-ff-copy)) - (not (= (get-file-format) - wx:const-media-ff-std))) - (cond - [(= format wx:const-media-ff-copy) - (set! restore-file-format - (let ([f (get-file-format)]) - (lambda () - (set! restore-file-format void) - (set-file-format f)))) - (set-file-format wx:const-media-ff-std)] - [(and (has-non-text-snips) - (or (not (mred:preferences:get-preference 'mred:verify-change-format)) - (mred:gui-utils:get-choice "Save this file as plain text?" "No" "Yes"))) - (set-file-format wx:const-media-ff-std)] - [else (void)])) - (or (super-on-save-file name format) - (begin - (restore-file-format) - #f))))] - [check-lock - (lambda () - (let* ([filename (get-filename)] - [lock? (and (not (null? filename)) - (file-exists? filename) - (not (member - 'write - (file-or-directory-permissions - filename))))]) - (mred:debug:printf 'permissions - "locking: ~a (filename: ~a)" - lock? - filename) - (lock lock?)))] - [after-save-file - (lambda (success) - (when success - (check-lock)) - (super-after-save-file success) - (restore-file-format))] - - [autowrap-bitmap mred:icon:autowrap-bitmap] - [load-file - (opt-lambda ([filename null] [format wx:const-media-ff-guess]) - (if (file-exists? filename) - (super-load-file filename format) - (set-filename filename)))] - [after-load-file - (lambda (sucessful?) - (when sucessful? - (check-lock)) - (super-after-load-file sucessful?))] - [set-mode (lambda (m) (if mode @@ -286,8 +151,9 @@ find-named-style "Standard") set-delta (make-object wx:style-delta%)))))] [styles-fixed? #f] - [set-styles-fixed (lambda (b) (set! styles-fixed? b))] + [set-styles-fixed (lambda (b) (set! styles-fixed? b))]) + (public [on-focus (lambda (on?) (super-on-focus on?) @@ -357,6 +223,82 @@ (send mode after-set-position this)) (super-after-set-position))]) + (public + [set-max-width + (lambda (x) + (mred:debug:printf 'rewrap "rewrap: set-max-width: ~a" x) + (super-set-max-width x))] + [auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)] + [set-auto-set-wrap + (lambda (v) + (mred:debug:printf 'rewrap + "rewrap: set-auto-set-wrap: ~a (canvases ~a)" + v canvases) + (set! auto-set-wrap? v) + (for-each (lambda (c) (send c resize-edit)) canvases))] + + [rewrap + (lambda () + (if auto-set-wrap? + (let* ([current-width (get-max-width)] + [w-box (box 0)] + [new-width + (mzlib:function:foldl + (lambda (canvas sofar) + (send canvas call-as-primary-owner + (lambda () + (send (get-admin) + get-view null null + w-box (box 0)))) + (max (unbox w-box) sofar)) + 0 + canvases)]) + (mred:debug:printf 'rewrap "rewrap: new-width ~a current-width ~a" + new-width current-width) + (when (and (not (= current-width new-width)) + (< 0 new-width)) + (set-max-width new-width) + (mred:debug:printf 'rewrap "rewrap: attempted to wrap to: ~a actually wrapped to ~a" + new-width (get-max-width)))) + (begin + (mred:debug:printf 'rewrap "rewrap: wrapping to -1") + (set-max-width -1))))]) + + (public + [move/copy-to-edit + (lambda (dest-edit start end dest-position) + (let ([insert-edit (ivar dest-edit insert)]) + (split-snip start) + (split-snip end) + (let loop ([snip (find-snip end wx:const-snip-before)]) + (cond + [(or (null? 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))]) + '(wx:message-box (format "before: ~a" (eq? snip released/copied))) + (insert-edit released/copied dest-position dest-position) + '(wx:message-box (format "after: ~a" (eq? snip released/copied))) + (loop prev))]))))]) + + (public + [load-file + (opt-lambda ([filename null] [format wx:const-media-ff-guess]) + (let ([filename (if (null? filename) + (mred:finder:get-file) + filename)]) + (and filename + (if (file-exists? filename) + (super-load-file filename format) + (set-filename filename)))))]) + (private [range-rectangles null] [recompute-range-rectangles @@ -505,8 +447,23 @@ (send dc set-logical-function old-logical-function) (send dc set-pen old-pen) (send dc set-brush old-brush)))) - range-rectangles))]) + range-rectangles))]) + (public + [autowrap-bitmap null]) + (sequence + (apply super-init args) + (set-autowrap-bitmap autowrap-bitmap) + (let ([keymap (get-keymap)]) + (mred:keymap:set-keymap-error-handler keymap) + (mred:keymap:set-keymap-implied-shifts keymap) + (send keymap chain-to-keymap mred:keymap:global-keymap #f)))))) + (define make-searching-edit% + (lambda (super%) + (class super% args + (inherit get-end-position get-start-position last-position + find-string get-snip-position get-admin find-snip + get-keymap) (public [find-string-embedded (opt-lambda (str [direction 1] [start -1] @@ -529,17 +486,17 @@ [end-test (lambda (snip) (cond - [(null? snip) flat] - [(and (not (= -1 flat)) - (let* ([start (get-snip-position snip)] - [end (+ start (send snip get-count))]) - (if (= direction 1) - (and (<= start flat) - (< flat end)) - (and (< start flat) - (<= flat end))))) - flat] - [else #f]))] + [(null? snip) flat] + [(and (not (= -1 flat)) + (let* ([start (get-snip-position snip)] + [end (+ start (send snip get-count))]) + (if (= direction 1) + (and (<= start flat) + (< flat end)) + (and (< start flat) + (<= flat end))))) + flat] + [else #f]))] [pop-out (lambda () (let ([admin (get-admin)]) @@ -565,146 +522,143 @@ (loop (send current-snip next)) (loop (send current-snip previous))))]) (cond - [(end-test current-snip) => - (lambda (x) - (if (and (= x -1) pop-out?) - (pop-out) - (values this x)))] - [(is-a? current-snip wx:media-snip%) - (let-values ([(embedded embedded-pos) - (let ([media (send current-snip get-this-media)]) - (and (not (null? media)) - (send media find-string-embedded str - direction - (if (= 1 direction) - 0 - (send media last-position)) - -1 - get-start case-sensitive?)))]) - (if (= -1 embedded-pos) - (next-loop) - (values embedded embedded-pos)))] - [else (next-loop)]))))))]) + [(end-test current-snip) => + (lambda (x) + (if (and (= x -1) pop-out?) + (pop-out) + (values this x)))] + [(is-a? current-snip wx:media-snip%) + (let-values ([(embedded embedded-pos) + (let ([media (send current-snip get-this-media)]) + (and (not (null? media)) + (send media find-string-embedded str + direction + (if (= 1 direction) + 0 + (send media last-position)) + -1 + get-start case-sensitive?)))]) + (if (= -1 embedded-pos) + (next-loop) + (values embedded embedded-pos)))] + [else (next-loop)]))))))]) (sequence (apply super-init args) - (set-autowrap-bitmap autowrap-bitmap) (let ([keymap (get-keymap)]) (mred:keymap:set-keymap-error-handler keymap) (mred:keymap:set-keymap-implied-shifts keymap) - (send keymap chain-to-keymap mred:keymap:global-keymap #f)))))) + (send keymap chain-to-keymap mred:keymap:global-search-keymap #f)))))) - (define edit% (make-edit% mred:connections:connections-media-edit%)) - - (define make-return-edit% + (define make-file-buffer% (lambda (super%) - (class super% (return . args) - (rename [super-on-local-char on-local-char]) + (class super% args + (inherit get-keymap find-snip + get-filename lock get-style-list + modified? change-style set-modified + get-frame) + (rename [super-on-set-focus on-set-focus] + [super-on-kill-focus on-kill-focus] + [super-after-save-file after-save-file] + [super-after-load-file after-load-file]) + (public - [on-local-char - (lambda (key) - (let ([cr-code 13] - [lf-code 10] - [code (send key get-key-code)]) - (or (and (or (= lf-code code) - (= cr-code code)) - (return)) - (super-on-local-char key))))]) - (sequence - (apply super-init args))))) - - (define return-edit% (make-return-edit% edit%)) - - (define make-info-edit% - (lambda (super-info-edit%) - (class-asi super-info-edit% - (inherit get-frame get-start-position get-end-position - position-line line-start-position) - (rename [super-after-set-position after-set-position] - [super-after-edit-sequence after-edit-sequence] - [super-on-edit-sequence on-edit-sequence] - [super-after-insert after-insert] - [super-after-delete after-delete] - [super-lock lock] - [super-set-overwrite-mode set-overwrite-mode] - [super-set-anchor set-anchor]) + [on-kill-focus + (lambda () + (super-on-kill-focus) + (let ([frame (get-frame)]) + (when frame + (send (get-keymap) + remove-chained-keymap + (ivar frame keymap)))))] + [on-set-focus + (lambda () + (super-on-set-focus) + (let ([frame (get-frame)]) + (when frame + (send (get-keymap) + chain-to-keymap + (ivar frame keymap) + #t))))]) (private - [edit-sequence-depth 0] - [position-needs-updating #f] - [lock-needs-updating #f] - [anchor-needs-updating #f] - [overwrite-needs-updating #f] - [maybe-update-anchor + [check-lock (lambda () - (if (= edit-sequence-depth 0) - (send (get-frame) anchor-status-changed) - (set! anchor-needs-updating #t)))] - [maybe-update-overwrite - (lambda () - (if (= edit-sequence-depth 0) - (send (get-frame) overwrite-status-changed) - (set! overwrite-needs-updating #t)))] - [maybe-update-lock-icon - (lambda () - (if (= edit-sequence-depth 0) - (send (get-frame) lock-status-changed) - (set! lock-needs-updating #t)))] - [maybe-update-position-edit - (lambda () - (if (= edit-sequence-depth 0) - (update-position-edit) - (set! position-needs-updating #t)))] - [update-position-edit - (lambda () - (send (get-frame) edit-position-changed))]) - + (let* ([filename (get-filename)] + [lock? (and (not (null? filename)) + (file-exists? filename) + (not (member + 'write + (file-or-directory-permissions + filename))))]) + (mred:debug:printf 'permissions + "locking: ~a (filename: ~a)" + lock? + filename) + (lock lock?)))]) (public - [set-anchor - (lambda (x) - (super-set-anchor x) - (maybe-update-anchor))] - [set-overwrite-mode - (lambda (x) - (super-set-overwrite-mode x) - (maybe-update-overwrite))] - [lock - (lambda (x) - (super-lock x) - (maybe-update-lock-icon))] - [after-set-position - (lambda () - (maybe-update-position-edit) - (super-after-set-position))] - [after-insert - (lambda (start len) - (maybe-update-position-edit) - (super-after-insert start len))] - [after-delete - (lambda (start len) - (maybe-update-position-edit) - (super-after-delete start len))] - [after-edit-sequence - (lambda () - (set! edit-sequence-depth (sub1 edit-sequence-depth)) - (when (= 0 edit-sequence-depth) - (when anchor-needs-updating - (set! anchor-needs-updating #f) - (send (get-frame) overwrite-status-changed)) - (when lock-needs-updating - (set! lock-needs-updating #f) - (send (get-frame) anchor-status-changed)) - (when position-needs-updating - (set! position-needs-updating #f) - (update-position-edit)) - (when lock-needs-updating - (set! lock-needs-updating #f) - (send (get-frame) lock-status-changed))) - (super-after-edit-sequence))] - [on-edit-sequence - (lambda () - (set! edit-sequence-depth (add1 edit-sequence-depth)) - (super-on-edit-sequence))])))) + [after-save-file + (lambda (success) + (when success + (check-lock)) + (super-after-save-file success))] - (define info-edit% (make-info-edit% edit%)) + [after-load-file + (lambda (sucessful?) + (when sucessful? + (check-lock)) + (super-after-load-file sucessful?))] + [autowrap-bitmap mred:icon:autowrap-bitmap]) + (sequence + (apply super-init args) + (let ([keymap (get-keymap)]) + (mred:keymap:set-keymap-error-handler keymap) + (mred:keymap:set-keymap-implied-shifts keymap) + (send keymap chain-to-keymap mred:keymap:global-file-keymap #f)))))) + + (define make-clever-file-format-edit% + (lambda (super%) + (class-asi super% + (inherit get-file-format set-file-format find-snip) + (rename [super-on-save-file on-save-file] + [super-after-save-file after-save-file]) + + (private [restore-file-format void]) + + (public + [after-save-file + (lambda (success) + (restore-file-format) + (super-after-save-file success))] + [on-save-file + (let ([has-non-text-snips + (lambda () + (let loop ([s (find-snip 0 wx:const-snip-after)]) + (cond + [(null? s) #f] + [(is-a? s wx:text-snip%) + (loop (send s next))] + [else #t])))]) + (lambda (name format) + (when (and (or (= format wx:const-media-ff-same) + (= format wx:const-media-ff-copy)) + (not (= (get-file-format) + wx:const-media-ff-std))) + (cond + [(= format wx:const-media-ff-copy) + (set! restore-file-format + (let ([f (get-file-format)]) + (lambda () + (set! restore-file-format void) + (set-file-format f)))) + (set-file-format wx:const-media-ff-std)] + [(and (has-non-text-snips) + (or (not (mred:preferences:get-preference 'mred:verify-change-format)) + (mred:gui-utils:get-choice "Save this file as plain text?" "No" "Yes"))) + (set-file-format wx:const-media-ff-std)] + [else (void)])) + (or (super-on-save-file name format) + (begin + (restore-file-format) + #f))))])))) (define make-backup-autosave-buffer% (lambda (super-edit%) @@ -785,10 +739,138 @@ (apply super-init args) (mred:autosave:register-autosave this))))) - (define backup-autosave-edit% (make-backup-autosave-buffer% info-edit%)) + (define make-return-edit% + (lambda (super%) + (class super% (return . args) + (rename [super-on-local-char on-local-char]) + (public + [on-local-char + (lambda (key) + (let ([cr-code 13] + [lf-code 10] + [code (send key get-key-code)]) + (or (and (or (= lf-code code) + (= cr-code code)) + (return)) + (super-on-local-char key))))]) + (sequence + (apply super-init args))))) - (define make-pasteboard% make-std-buffer%) + (define make-info-edit% + (lambda (super-info-edit%) + (class-asi super-info-edit% + (inherit get-frame get-start-position get-end-position + position-line line-start-position) + (rename [super-after-set-position after-set-position] + [super-after-edit-sequence after-edit-sequence] + [super-on-edit-sequence on-edit-sequence] + [super-after-insert after-insert] + [super-after-delete after-delete] + [super-lock lock] + [super-set-overwrite-mode set-overwrite-mode] + [super-set-anchor set-anchor]) + (private + [edit-sequence-depth 0] + [position-needs-updating #f] + [lock-needs-updating #f] + [anchor-needs-updating #f] + [overwrite-needs-updating #f] + [maybe-update-anchor + (lambda () + (if (= edit-sequence-depth 0) + (let ([frame (get-frame)]) + (when frame + (send frame anchor-status-changed))) + (set! anchor-needs-updating #t)))] + [maybe-update-overwrite + (lambda () + (if (= edit-sequence-depth 0) + (let ([frame (get-frame)]) + (when frame + (send frame overwrite-status-changed))) + (set! overwrite-needs-updating #t)))] + [maybe-update-lock-icon + (lambda () + (if (= edit-sequence-depth 0) + (let ([frame (get-frame)]) + (when frame + (send frame lock-status-changed))) + (set! lock-needs-updating #t)))] + [maybe-update-position-edit + (lambda () + (if (= edit-sequence-depth 0) + (update-position-edit) + (set! position-needs-updating #t)))] + [update-position-edit + (lambda () + (let ([frame (get-frame)]) + (when frame + (send frame edit-position-changed))))]) + + (public + [set-anchor + (lambda (x) + (super-set-anchor x) + (maybe-update-anchor))] + [set-overwrite-mode + (lambda (x) + (super-set-overwrite-mode x) + (maybe-update-overwrite))] + [lock + (lambda (x) + (super-lock x) + (maybe-update-lock-icon))] + [after-set-position + (lambda () + (maybe-update-position-edit) + (super-after-set-position))] + [after-insert + (lambda (start len) + (maybe-update-position-edit) + (super-after-insert start len))] + [after-delete + (lambda (start len) + (maybe-update-position-edit) + (super-after-delete start len))] + [after-edit-sequence + (lambda () + (set! edit-sequence-depth (sub1 edit-sequence-depth)) + (when (= 0 edit-sequence-depth) + (let ([frame (get-frame)]) + (when anchor-needs-updating + (set! anchor-needs-updating #f) + (send frame overwrite-status-changed)) + (when lock-needs-updating + (set! lock-needs-updating #f) + (send frame anchor-status-changed)) + (when position-needs-updating + (set! position-needs-updating #f) + (update-position-edit)) + (when lock-needs-updating + (set! lock-needs-updating #f) + (send frame lock-status-changed)))) + (super-after-edit-sequence))] + [on-edit-sequence + (lambda () + (set! edit-sequence-depth (add1 edit-sequence-depth)) + (super-on-edit-sequence))])))) + + + (define media-edit% (make-media-edit% + (make-std-buffer% + mred:connections:connections-media-edit%))) + + (define info-edit% (make-info-edit% media-edit%)) + + (define searching-edit% (make-searching-edit% info-edit%)) + (define clever-file-format-edit% (make-clever-file-format-edit% searching-edit%)) + (define file-edit% (make-file-buffer% clever-file-format-edit%)) + (define backup-autosave-edit% (make-backup-autosave-buffer% file-edit%)) + + (define edit% file-edit%) + + (define return-edit% (make-return-edit% media-edit%)) (define pasteboard% (make-pasteboard% mred:connections:connections-media-pasteboard%)) - + (define file-pasteboard% (make-file-buffer% pasteboard%)) (define backup-autosave-pasteboard% (make-backup-autosave-buffer% edit%))) diff --git a/collects/mred/finder.ss b/collects/mred/finder.ss index 8c044bc4..eed6c59e 100644 --- a/collects/mred/finder.ss +++ b/collects/mred/finder.ss @@ -282,7 +282,7 @@ () wx:const-needed-sb)] [save-panel (when save-mode? (make-object mred:container:horizontal-panel% main-panel))] [directory-panel (make-object mred:container:horizontal-panel% main-panel)] - [directory-edit (make-object (class-asi mred:edit:edit% + [directory-edit (make-object (class-asi mred:edit:media-edit% (rename [super-on-local-char on-local-char]) (public [on-local-char diff --git a/collects/mred/keys.ss b/collects/mred/keys.ss index 2415c2cb..4b003cb8 100644 --- a/collects/mred/keys.ss +++ b/collects/mred/keys.ss @@ -50,9 +50,46 @@ (or (not x) (eq? x #t)))) - ; This installs the standard keyboard mapping - (define setup-global-keymap - ; Define some useful keyboard functions + (define setup-global-search-keymap + (let* ([find-string + (lambda (edit event . extras) + (let ([x-box (box 0)] + [y-box (box 0)] + [canvas (send event get-event-object)]) + (send event position x-box y-box) + (send canvas client-to-screen x-box y-box) + (mred:find-string:find-string canvas () + (- (unbox x-box) 30) + (- (unbox y-box) 30) + (cons 'ignore-case extras)) + #t))] + [find-string-reverse + (lambda (edit event) + (find-string edit event 'reverse))] + [find-string-replace + (lambda (edit event) + (find-string edit event 'replace))]) + (lambda (kmap) + (let* ([map (lambda (key func) + (send kmap map-function key func))] + [map-meta (lambda (key func) + (send-map-function-meta kmap key func))] + [add (lambda (name func) + (send kmap add-key-function name func))] + [add-m (lambda (name func) + (send kmap add-mouse-function name func))]) + + + (add "find-string" find-string) + (add "find-string-reverse" find-string-reverse) + (add "find-string-replace" find-string-replace) + + (map "c:x;c:s" "save-file") + (map "d:s" "save-file") + (map "c:x;c:w" "save-file-as") + (map "c:x;c:f" "load-file"))))) + + (define setup-global-file-keymap (let* ([rcs (let ([last-checkin-string ""]) (mred:preferences:set-preference-default @@ -121,17 +158,6 @@ (send edit get-filename) (send edit get-file-format)) (wx:message-box "Checkout Failed")))))]))))))))] - - [ring-bell - (lambda (edit event) - (let ([c (send edit get-canvas)]) - (when c - (let ([f (let loop ([f c]) - (if (is-a? f wx:frame%) - f - (loop (send f get-parent))))]) - (send f hide-search)))) - (wx:bell))] [save-file-as (lambda (edit event) (let ([file (mred:finder:put-file)]) @@ -147,25 +173,44 @@ [load-file (lambda (edit event) (mred:handler:open-file) - #t)] - [find-string - (lambda (edit event . extras) - (let ([x-box (box 0)] - [y-box (box 0)] - [canvas (send event get-event-object)]) - (send event position x-box y-box) - (send canvas client-to-screen x-box y-box) - (mred:find-string:find-string canvas () - (- (unbox x-box) 30) - (- (unbox y-box) 30) - (cons 'ignore-case extras)) - #t))] - [find-string-reverse + #t)]) + (lambda (kmap) + (map (lambda (k) (send kmap implies-shift k)) shifted-key-list) + (let* ([map (lambda (key func) + (send kmap map-function key func))] + [map-meta (lambda (key func) + (send-map-function-meta kmap key func))] + [add (lambda (name func) + (send kmap add-key-function name func))] + [add-m (lambda (name func) + (send kmap add-mouse-function name func))]) + + (add "rcs" rcs) + + (add "save-file" save-file) + (add "save-file-as" save-file-as) + (add "load-file" load-file) + + (when (eq? wx:platform 'unix) + '(map "c:x;c:q" "rcs")) + (map "c:x;c:s" "save-file") + (map "d:s" "save-file") + (map "c:x;c:w" "save-file-as") + (map "c:x;c:f" "load-file"))))) + + ; This installs the standard keyboard mapping + (define setup-global-keymap + ; Define some useful keyboard functions + (let* ([ring-bell (lambda (edit event) - (find-string edit event 'reverse))] - [find-string-replace - (lambda (edit event) - (find-string edit event 'replace))] + (let ([c (send edit get-canvas)]) + (when c + (let ([f (let loop ([f c]) + (if (is-a? f wx:frame%) + f + (loop (send f get-parent))))]) + (send f hide-search)))) + (wx:bell))] [toggle-anchor (lambda (edit event) @@ -682,8 +727,6 @@ ; Map names to keyboard functions (add "toggle-overwrite" toggle-overwrite) - (add "rcs" rcs) - (add "exit" (lambda (edit event) (let ([frame (send edit get-frame)]) (if frame @@ -692,14 +735,6 @@ (add "ring-bell" ring-bell) - (add "save-file" save-file) - (add "save-file-as" save-file-as) - (add "load-file" load-file) - - (add "find-string" find-string) - (add "find-string-reverse" find-string-reverse) - (add "find-string-replace" find-string-replace) - (add "flash-paren-match" flash-paren-match) (add "toggle-anchor" toggle-anchor) @@ -742,12 +777,6 @@ (add "delete-key" delete-key) ; Map keys to functions - - ; this is not for export -- too much chance it's wrong - ; outside of Rice. - (when (eq? wx:platform 'unix) - '(map "c:x;c:q" "rcs")) - (map "c:g" "ring-bell") (map-meta "c:g" "ring-bell") (map "c:x;c:g" "ring-bell") @@ -869,15 +898,6 @@ (map "a:c" "copy-clipboard") (map "d:c" "copy-clipboard") - (map "c:x;c:s" "save-file") - (map "d:s" "save-file") - (map "c:x;c:w" "save-file-as") - (map "c:x;c:f" "load-file") - - (map "c:s" "find-string") - (map "c:r" "find-string-reverse") - (map-meta "%" "find-string-replace") - (map-meta "space" "collapse-space") (map-meta "\\" "remove-space") (map "c:x;c:o" "collapse-newline") @@ -915,5 +935,10 @@ (map "c:rightbutton" "copy-clipboard"))))) (define global-keymap (make-object wx:keymap%)) - - (setup-global-keymap global-keymap)) + (setup-global-keymap global-keymap) + + (define global-file-keymap (make-object wx:keymap%)) + (setup-global-file-keymap global-file-keymap) + + (define global-search-keymap (make-object wx:keymap%)) + (setup-global-search-keymap global-search-keymap)) diff --git a/collects/mred/prefs.ss b/collects/mred/prefs.ss index 419e765e..76fa0479 100644 --- a/collects/mred/prefs.ss +++ b/collects/mred/prefs.ss @@ -38,9 +38,8 @@ msg ((debug-info-handler))))))]) - (with-handlers ([void h]) - (thunk)) - ))) + (with-handlers ([(lambda (x) #t) h]) + (thunk))))) (define unmarshall (lambda (p marshalled) @@ -183,21 +182,27 @@ [else (error 'prefs.ss "robby error.2: ~a" ht-value)]))]) (lambda () (mred:debug:printf 'prefs "saving user preferences") - (call-with-output-file preferences-filename - (lambda (p) - (mzlib:pretty-print:pretty-print - (hash-table-map preferences marshall-pref) p)) - 'truncate 'text) + (with-handlers ([(lambda (x) #t) + (lambda (exn) + (mred:gui-utils:message-box + (format "Error saving preferences~n~a" + (exn-message exn)) + "Error saving preferences"))]) + (call-with-output-file preferences-filename + (lambda (p) + (mzlib:pretty-print:pretty-print + (hash-table-map preferences marshall-pref) p)) + 'truncate 'text)) (mred:debug:printf 'prefs "saved user preferences")))) (mred:exit:insert-exit-callback (lambda () (with-handlers ([(lambda (x) #t) (lambda (exn) - (mred:gui-utils:message-box - (format "error while saving prefs: ~a" - (exn-message exn)) - "Saving Prefs"))]) + (mred:gui-utils:message-box + (format "error while saving prefs: ~a" + (exn-message exn)) + "Saving Prefs"))]) (save-user-preferences)))) (define read-user-preferences @@ -226,31 +231,40 @@ [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))]) (lambda () (mred:debug:printf 'prefs "reading user preferences") - (when (file-exists? preferences-filename) - (let ([err - (lambda (input) - (wx:message-box (format "found bad pref: ~n~a" input) - "Preferences"))]) - (let loop ([input (call-with-input-file preferences-filename - read - 'text)]) - (cond - [(pair? input) - (let/ec k - (let ([first (car input)]) - (when (pair? first) - (let ([arg1 (car first)] - [t1 (cdr first)]) - (when (pair? t1) - (let ([arg2 (car t1)] - [t2 (cdr t1)]) - (when (null? t2) - (parse-pref arg1 arg2) - (k #t))))))) - (err input)) - (loop (cdr input))] - [(null? input) (void)] - [else (err input)])))) + (let/ec k + (when (file-exists? preferences-filename) + (let ([err + (lambda (input) + (mred:gui-utils:message-box (format "found bad pref: ~n~a" input) + "Preferences"))]) + (let loop ([input (with-handlers + ([(lambda (exn) #t) + (lambda (exn) + (mred:gui-utils:message-box + (format "Error saving preferences~n~a" + (exn-message exn)) + "Error reading preferences") + (k #f))]) + (call-with-input-file preferences-filename + read + 'text))]) + (cond + [(pair? input) + (let/ec k + (let ([first (car input)]) + (when (pair? first) + (let ([arg1 (car first)] + [t1 (cdr first)]) + (when (pair? t1) + (let ([arg2 (car t1)] + [t2 (cdr t1)]) + (when (null? t2) + (parse-pref arg1 arg2) + (k #t))))))) + (err input)) + (loop (cdr input))] + [(null? input) (void)] + [else (err input)]))))) (mred:debug:printf 'prefs "read user preferences")))) (define-struct ppanel (title container panel)) @@ -285,12 +299,12 @@ (lambda (x) (if x 'std 'common)) (lambda (x) (eq? x 'std))) - ;; sleep is not effecient, so we wait for the next release to turn this on. - (make-check 'mred:show-status-line "Show status-line?" id id) - (make-check 'mred:verify-exit "Verify exit?" id id) (make-check 'mred:verify-change-format "Ask before changing save format?" id id) (make-check 'mred:auto-set-wrap? "Wordwrap editor buffers?" id id) + + (make-check 'mred:show-status-line "Show status-line?" id id) + (make-check 'mred:line-offsets "Count line and column numbers from one?" id id) main)) #f)))