From ace788472e4b9d8789f561d141b43a81b307cba2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 14 Jun 1996 16:41:56 +0000 Subject: [PATCH] added paren highlighting and fixed drscheme/quit bug original commit: c157ca5bc72bd94fa0c9df123805d0294662a941 --- collects/mred/edit.ss | 427 +++++++++++++++++++++++----------------- collects/mred/finder.ss | 12 +- 2 files changed, 251 insertions(+), 188 deletions(-) diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss index 5a1a7c70..a17044c8 100644 --- a/collects/mred/edit.ss +++ b/collects/mred/edit.ss @@ -1,144 +1,142 @@ (define-sigfunctor (mred:edit@ mred:edit^) - (import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^ mred:scheme-paren^ - mred:keymap^ mzlib:function^) + (import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^ + mred:scheme-paren^ mred:keymap^ mzlib:function^) - (define first car) - (define second cadr) - (define third caddr) - (define fourth cadddr) + (define-struct range (start end pen brush)) + (define-struct rectangle (left top width height pen brush)) (define make-std-buffer% (lambda (buffer%) (class buffer% args (inherit modified? get-filename save-file set-max-width) (rename - [super-set-filename set-filename] - [super-set-modified set-modified] - [super-on-change on-change] - [super-on-save-file on-save-file]) + [super-set-filename set-filename] + [super-set-modified set-modified] + [super-on-change on-change] + [super-on-save-file on-save-file]) (private - [auto-saved-name #f] - [auto-save-out-of-date? #t] - [auto-save-error? #f]) + [auto-saved-name #f] + [auto-save-out-of-date? #t] + [auto-save-error? #f]) (public - [get-file (lambda (d) (let ([v (mred:finder^:get-file d)]) - (if v - v - '())))] - [put-file (lambda (d f) (let ([v (mred:finder^:put-file f d)]) - (if v - v - '())))] - - [auto-set-wrap? #f] - [set-auto-set-wrap - (lambda (v) - (set! auto-set-wrap? v) - (if (not v) - (set-max-width -1)))] - - [active-canvas #f] - [set-active-canvas - (lambda (c) - (set! active-canvas c))] - - [canvases '()] - [add-canvas - (lambda (canvas) - (set! canvases (cons canvas canvases)))] - [remove-canvas - (lambda (canvas) - (set! canvases (mzlib:function^:remove canvas canvases)))] - - [mode #f] - [set-mode - (lambda (m) - #f)] - - [set-modified - (lambda (modified?) - (if auto-saved-name - (if (not modified?) - (begin - (delete-file auto-saved-name) - (set! auto-saved-name #f)) - (set! auto-save-out-of-date? #t))) - (super-set-modified modified?) - (for-each (lambda (canvas) (send canvas edit-modified modified?)) - canvases))] - [set-filename - (opt-lambda (name [temp? #f]) - (super-set-filename name temp?) - (for-each (lambda (canvas) (send canvas edit-renamed name)) - canvases))] - - [on-change - (lambda () - (super-on-change) - (set! auto-save-out-of-date? #t))] - [auto-save? #t] - [do-autosave - (lambda () - (when (and auto-save? - (not auto-save-error?) - (modified?) - (or (not auto-saved-name) - auto-save-out-of-date?)) - (let* ([orig-name (get-filename)] - [auto-name (mred:path-utils^:generate-autosave-name orig-name)] - [success (save-file auto-name wx:const-media-ff-copy)]) - (if success - (begin - (if auto-saved-name - (delete-file auto-saved-name)) - (set! auto-saved-name auto-name) - (set! auto-save-out-of-date? #f)) - (begin - (wx:message-box - (format "Error autosaving ~s.~n~a~n~a" - (if (null? orig-name) "Untitled" orig-name) - "Autosaving is turned off" - "until the file is saved.") - "Warning") - (set! auto-save-error? #t))))))] - [remove-autosave - (lambda () - (when auto-saved-name - (delete-file auto-saved-name) - (set! auto-saved-name #f)))] - - [backup? #t] - [on-save-file - (lambda (name format) - (set! auto-save-error? #f) - (if (super-on-save-file name format) - (begin - (if (and backup? - (not (= format wx:const-media-ff-copy))) - (if (file-exists? name) - (let ([back-name (mred:path-utils^:generate-backup-name name)]) - (unless (file-exists? back-name) - (rename-file name back-name))))) - #t) - #f))] - - [get-canvas - (lambda () - (cond - [(and active-canvas - (member active-canvas canvases)) - active-canvas] - [(null? canvases) #f] - [else (car canvases)]))] - [get-frame - (lambda () - (let ([c (get-canvas)]) - (if c - (let ([f (send c get-parent)]) - (if (null? f) - #f - f)) - #f)))]) + [get-file (lambda (d) (let ([v (mred:finder^:get-file d)]) + (if v + v + '())))] + [put-file (lambda (d f) (let ([v (mred:finder^:put-file f d)]) + (if v + v + '())))] + + [auto-set-wrap? #f] + [set-auto-set-wrap + (lambda (v) + (set! auto-set-wrap? v) + (if (not v) + (set-max-width -1)))] + + [active-canvas #f] + [set-active-canvas + (lambda (c) + (set! active-canvas c))] + + [canvases '()] + [add-canvas + (lambda (canvas) + (set! canvases (cons canvas canvases)))] + [remove-canvas + (lambda (canvas) + (set! canvases (mzlib:function^:remove canvas canvases)))] + + [mode #f] + [set-mode + (lambda (m) + #f)] + + [set-modified + (lambda (modified?) + (if auto-saved-name + (if (not modified?) + (begin + (delete-file auto-saved-name) + (set! auto-saved-name #f)) + (set! auto-save-out-of-date? #t))) + (super-set-modified modified?) + (for-each (lambda (canvas) (send canvas edit-modified modified?)) + canvases))] + [set-filename + (opt-lambda (name [temp? #f]) + (super-set-filename name temp?) + (for-each (lambda (canvas) (send canvas edit-renamed name)) + canvases))] + + [on-change + (lambda () + (super-on-change) + (set! auto-save-out-of-date? #t))] + [auto-save? #t] + [do-autosave + (lambda () + (when (and auto-save? + (not auto-save-error?) + (modified?) + (or (not auto-saved-name) + auto-save-out-of-date?)) + (let* ([orig-name (get-filename)] + [auto-name (mred:path-utils^:generate-autosave-name orig-name)] + [success (save-file auto-name wx:const-media-ff-copy)]) + (if success + (begin + (if auto-saved-name + (delete-file auto-saved-name)) + (set! auto-saved-name auto-name) + (set! auto-save-out-of-date? #f)) + (begin + (wx:message-box + (format "Error autosaving ~s.~n~a~n~a" + (if (null? orig-name) "Untitled" orig-name) + "Autosaving is turned off" + "until the file is saved.") + "Warning") + (set! auto-save-error? #t))))))] + [remove-autosave + (lambda () + (when auto-saved-name + (delete-file auto-saved-name) + (set! auto-saved-name #f)))] + + [backup? #t] + [on-save-file + (lambda (name format) + (set! auto-save-error? #f) + (if (super-on-save-file name format) + (begin + (if (and backup? + (not (= format wx:const-media-ff-copy))) + (if (file-exists? name) + (let ([back-name (mred:path-utils^:generate-backup-name name)]) + (unless (file-exists? back-name) + (rename-file name back-name))))) + #t) + #f))] + + [get-canvas + (lambda () + (cond + [(and active-canvas + (member active-canvas canvases)) + active-canvas] + [(null? canvases) #f] + [else (car canvases)]))] + [get-frame + (lambda () + (let ([c (get-canvas)]) + (if c + (let ([f (send c get-parent)]) + (if (null? f) + #f + f)) + #f)))]) (sequence (apply super-init args))))) @@ -163,18 +161,29 @@ (lambda (super%) (class (make-std-buffer% super%) args (inherit mode canvases + invalidate-bitmap-cache + begin-edit-sequence end-edit-sequence flash-on get-keymap get-start-position on-default-char on-default-event set-file-format get-style-list) (rename [super-on-focus on-focus] [super-on-paint on-paint] - [super-after-set-position after-set-position] [super-on-local-event on-local-event] [super-on-local-char on-local-char] + + [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-edit-sequence after-edit-sequence] + [super-after-change-style after-change-style] [super-after-insert after-insert] - [super-after-delete after-delete]) + [super-after-delete after-delete] + [super-after-set-size-constraint after-set-size-constraint]) (public [set-mode (lambda (m) @@ -211,6 +220,19 @@ (lambda (start len) (if (or (not mode) (send mode on-delete this start len)) (super-on-delete start len)))] + [on-change-style + (lambda (start len) + (if (or (not mode) (send mode on-change-style this start len)) + (super-on-change-style start len)))] + [on-edit-sequence + (lambda () + (when mode + (send mode on-edit-sequence this)) + (super-on-edit-sequence))] + [on-set-size-constraint + (lambda () + (if (or (not mode) (send mode on-set-size-constraint this)) + (super-on-set-size-constraint)))] [after-insert (lambda (start len) @@ -220,81 +242,122 @@ (lambda (start len) (if mode (send mode after-delete this start len)) (super-after-delete start len))] - + [after-change-style + (lambda (start len) + (when mode (send mode after-change-style this start len)) + (super-after-change-style start len))] + [after-edit-sequence + (lambda () + (when mode + (send mode after-edit-sequence this)) + (super-after-edit-sequence))] + [after-set-size-constraint + (lambda () + (when mode + (send mode after-set-size-constraint this)) + (super-after-set-size-constraint))] + [after-set-position (lambda () (when mode (send mode after-set-position this)) (super-after-set-position))] - [ranges (list (list 4 24 '... '...))] + [ranges null] [add-range - (lambda (start end b/w-pattern color-pattern) - (let ([l (list start end b/w-pattern color-pattern)]) + (lambda (start end pen brush) + (let ([l (make-range start end pen brush)]) (set! ranges (cons l ranges)) + (recompute-range-rectangles) (lambda () (set! ranges (let loop ([r ranges]) (cond [(null? r) r] [else (if (eq? (car r) l) (cdr r) - (cons (car r) (loop (cdr r))))]))))))] + (cons (car r) (loop (cdr r))))]))) + (recompute-range-rectangles))))] [range-rectangles null] [recompute-range-rectangles (lambda () - (let ([new-rectangles - (lambda (start end b/w color) - (let ([left 0] - [right 1000] - [top-start-x (box 0)] + (let ([new-rectangles + (lambda (range) + (let ([start (range-start range)] + [end (range-end range)] + [pen (range-pen range)] + [brush (range-brush range)] + [buffer-width (box 0)] + [start-x (box 0)] [top-start-y (box 0)] - [bottom-start-x (box 0)] [bottom-start-y (box 0)] - [top-end-x (box 0)] + [end-x (box 0)] [top-end-y (box 0)] - [bottom-end-x (box 0)] [bottom-end-y (box 0)]) - (send this position-location start top-start-x top-start-y #t #f #t) - (send this position-location end top-end-x top-end-y #t #t #t) - (send this position-location start bottom-start-x bottom-start-y #f #f #t) - (send this position-location end bottom-end-x bottom-end-y #f #t #t) + (send this get-extent buffer-width null) + (send this position-location start start-x top-start-y #t #f #t) + (send this position-location end end-x top-end-y #t #t #t) + (send this position-location start start-x bottom-start-y #f #f #t) + (send this position-location end end-x bottom-end-y #f #t #t) (cond [(= (unbox top-start-y) (unbox top-end-y)) - (list (list (unbox top-start-x) (unbox top-start-y) - (- (unbox bottom-end-x) (unbox top-start-x)) - (- (unbox bottom-end-y) (unbox top-start-y))))] + (list (make-rectangle (unbox start-x) + (unbox top-start-y) + (- (unbox end-x) (unbox start-x)) + (- (unbox bottom-start-y) (unbox top-start-y)) + pen brush))] [else - (list (list (unbox top-start-x) (unbox top-start-y) - (- right (unbox top-start-x)) - (- (unbox bottom-start-y) (unbox top-start-y))) - (list (unbox bottom-start-x) left - (- right left) (- (unbox bottom-start-x) (unbox top-end-x))) - (list left (unbox top-end-y) - (- (unbox top-end-x) left) - (- (unbox bottom-end-y) (unbox top-end-y))))])))]) - (set! range-rectangles (map (lambda (x) (apply new-rectangles x)) ranges)) - (printf "~a~n" range-rectangles)))] + (list + (make-rectangle (unbox start-x) + (unbox top-start-y) + (- (unbox buffer-width) (unbox start-x)) + (- (unbox bottom-start-y) (unbox top-start-y)) + pen brush) + (make-rectangle 0 + (unbox bottom-start-y) + (unbox buffer-width) + (- (unbox top-end-y) (unbox bottom-start-y)) + pen brush) + (make-rectangle 0 + (unbox top-end-y) + (unbox end-x) + (- (unbox bottom-end-y) (unbox top-end-y)) + pen brush))])))] + [invalidate-rectangle + (lambda (r) + (invalidate-bitmap-cache (rectangle-left r) + (rectangle-top r) + (rectangle-width r) + (rectangle-height r)))] + [old-rectangles range-rectangles]) + + (set! range-rectangles + (mzlib:function^:foldl (lambda (x l) (append (new-rectangles x) l)) + null ranges)) + (begin-edit-sequence) + (for-each invalidate-rectangle old-rectangles) + (for-each invalidate-rectangle range-rectangles) + (end-edit-sequence)))] [on-paint (lambda (before dc left top right bottom dx dy draw-caret) - (when #f - (for-each (lambda (rlist) - (for-each (lambda (rectangle) - (let ([pen (make-object wx:pen% "black" 1 1)] - [brush (make-object wx:brush% "black" wx:const-transparent)] - [old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-pen pen) - (send dc set-brush brush) - (send dc draw-rectangle - (+ (first rectangle) dx) - (+ (second rectangle) dy) - (+ (third rectangle) dx) - (+ (fourth rectangle) dy)) - (send dc set-pen old-pen) - (send dc set-brush old-brush))) - rlist)) - range-rectangles)) - (super-on-paint before dc left top right bottom dx dy draw-caret))]) + (super-on-paint before dc left top right bottom dx dy draw-caret) + (unless before + (for-each (lambda (rectangle) + (let ([pen (rectangle-pen rectangle)] + [brush (rectangle-brush rectangle)] + [old-pen (send dc get-pen)] + [old-brush (send dc get-brush)] + [left (rectangle-left rectangle)] + [top (rectangle-top rectangle)] + [width (rectangle-width rectangle)] + [height (rectangle-height rectangle)]) + (send dc set-pen pen) + (send dc set-brush brush) + (unless (or (zero? width) + (zero? height)) + (send dc draw-rectangle (+ left dx) (+ top dy) width height)) + (send dc set-pen old-pen) + (send dc set-brush old-brush))) + range-rectangles)))]) (sequence (apply super-init args) (send edits add this) diff --git a/collects/mred/finder.ss b/collects/mred/finder.ss index 4c5f4109..570816a6 100644 --- a/collects/mred/finder.ss +++ b/collects/mred/finder.ss @@ -347,10 +347,10 @@ [filter-msg "That name does not have the right form"]) (let* ([directory (if (and (null? directory) (string? name)) - (mzlib:file^:path-only name) + (or (mzlib:file^:path-only name) null) directory)] - [name (if (string? name) - (mzlib:file^:file-name-from-path name) + [name (or (and (string? name) + (mzlib:file^:file-name-from-path name)) name)] [v (box #f)]) (make-object finder-dialog% #t replace? #f v @@ -382,8 +382,8 @@ (string? name)) (or (mzlib:file^:path-only name) null) directory)] - [name (if (string? name) - (mzlib:file^:file-name-from-path name) + [name (or (and (string? name) + (mzlib:file^:file-name-from-path name)) name)] [f (wx:file-selector prompt directory name '() @@ -402,7 +402,7 @@ [(not (and (string? dir) (directory-exists? dir))) (wx:message-box "Error" "That directory does not exist.") #f] - [(equal? name "") + [(or (not name) (equal? name "")) (wx:message-box "Error" "Empty filename.") #f] [else f]))))))