suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added paren highlighting and fixed drscheme/quit bug

Browse Source 
original commit: c157ca5bc72bd94fa0c9df123805d0294662a941
This commit is contained in:
Robby Findler 1996-06-14 16:41:56 +00:00
parent f2798942a9
commit ace788472e
2 changed files with 251 additions and 188 deletions
collects/mred
edit.ssfinder.ss

427
collects/mred/edit.ss
View File

@ -1,144 +1,142 @@
(define-sigfunctor (mred:edit@ mred:edit^) (define-sigfunctor (mred:edit@ mred:edit^)
(import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^ mred:scheme-paren^ (import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^
mred:keymap^ mzlib:function^) mred:scheme-paren^ mred:keymap^ mzlib:function^)
(define first car) (define-struct range (start end pen brush))
(define second cadr) (define-struct rectangle (left top width height pen brush))
(define third caddr)
(define fourth cadddr)
(define make-std-buffer% (define make-std-buffer%
(lambda (buffer%) (lambda (buffer%)
(class buffer% args (class buffer% args
(inherit modified? get-filename save-file set-max-width) (inherit modified? get-filename save-file set-max-width)
(rename (rename
[super-set-filename set-filename] [super-set-filename set-filename]
[super-set-modified set-modified] [super-set-modified set-modified]
[super-on-change on-change] [super-on-change on-change]
[super-on-save-file on-save-file]) [super-on-save-file on-save-file])
(private (private
[auto-saved-name #f] [auto-saved-name #f]
[auto-save-out-of-date? #t] [auto-save-out-of-date? #t]
[auto-save-error? #f]) [auto-save-error? #f])
(public (public
[get-file (lambda (d) (let ([v (mred:finder^:get-file d)]) [get-file (lambda (d) (let ([v (mred:finder^:get-file d)])
(if v (if v
v v
'())))] '())))]
[put-file (lambda (d f) (let ([v (mred:finder^:put-file f d)]) [put-file (lambda (d f) (let ([v (mred:finder^:put-file f d)])
(if v (if v
v v
'())))] '())))]
[auto-set-wrap? #f] [auto-set-wrap? #f]
[set-auto-set-wrap [set-auto-set-wrap
(lambda (v) (lambda (v)
(set! auto-set-wrap? v) (set! auto-set-wrap? v)
(if (not v) (if (not v)
(set-max-width -1)))] (set-max-width -1)))]
[active-canvas #f] [active-canvas #f]
[set-active-canvas [set-active-canvas
(lambda (c) (lambda (c)
(set! active-canvas c))] (set! active-canvas c))]
[canvases '()] [canvases '()]
[add-canvas [add-canvas
(lambda (canvas) (lambda (canvas)
(set! canvases (cons canvas canvases)))] (set! canvases (cons canvas canvases)))]
[remove-canvas [remove-canvas
(lambda (canvas) (lambda (canvas)
(set! canvases (mzlib:function^:remove canvas canvases)))] (set! canvases (mzlib:function^:remove canvas canvases)))]
[mode #f] [mode #f]
[set-mode [set-mode
(lambda (m) (lambda (m)
#f)] #f)]
[set-modified [set-modified
(lambda (modified?) (lambda (modified?)
(if auto-saved-name (if auto-saved-name
(if (not modified?) (if (not modified?)
(begin (begin
(delete-file auto-saved-name) (delete-file auto-saved-name)
(set! auto-saved-name #f)) (set! auto-saved-name #f))
(set! auto-save-out-of-date? #t))) (set! auto-save-out-of-date? #t)))
(super-set-modified modified?) (super-set-modified modified?)
(for-each (lambda (canvas) (send canvas edit-modified modified?)) (for-each (lambda (canvas) (send canvas edit-modified modified?))
canvases))] canvases))]
[set-filename [set-filename
(opt-lambda (name [temp? #f]) (opt-lambda (name [temp? #f])
(super-set-filename name temp?) (super-set-filename name temp?)
(for-each (lambda (canvas) (send canvas edit-renamed name)) (for-each (lambda (canvas) (send canvas edit-renamed name))
canvases))] canvases))]
[on-change [on-change
(lambda () (lambda ()
(super-on-change) (super-on-change)
(set! auto-save-out-of-date? #t))] (set! auto-save-out-of-date? #t))]
[auto-save? #t] [auto-save? #t]
[do-autosave [do-autosave
(lambda () (lambda ()
(when (and auto-save? (when (and auto-save?
(not auto-save-error?) (not auto-save-error?)
(modified?) (modified?)
(or (not auto-saved-name) (or (not auto-saved-name)
auto-save-out-of-date?)) auto-save-out-of-date?))
(let* ([orig-name (get-filename)] (let* ([orig-name (get-filename)]
[auto-name (mred:path-utils^:generate-autosave-name orig-name)] [auto-name (mred:path-utils^:generate-autosave-name orig-name)]
[success (save-file auto-name wx:const-media-ff-copy)]) [success (save-file auto-name wx:const-media-ff-copy)])
(if success (if success
(begin (begin
(if auto-saved-name (if auto-saved-name
(delete-file auto-saved-name)) (delete-file auto-saved-name))
(set! auto-saved-name auto-name) (set! auto-saved-name auto-name)
(set! auto-save-out-of-date? #f)) (set! auto-save-out-of-date? #f))
(begin (begin
(wx:message-box (wx:message-box
(format "Error autosaving ~s.~n~a~n~a" (format "Error autosaving ~s.~n~a~n~a"
(if (null? orig-name) "Untitled" orig-name) (if (null? orig-name) "Untitled" orig-name)
"Autosaving is turned off" "Autosaving is turned off"
"until the file is saved.") "until the file is saved.")
"Warning") "Warning")
(set! auto-save-error? #t))))))] (set! auto-save-error? #t))))))]
[remove-autosave [remove-autosave
(lambda () (lambda ()
(when auto-saved-name (when auto-saved-name
(delete-file auto-saved-name) (delete-file auto-saved-name)
(set! auto-saved-name #f)))] (set! auto-saved-name #f)))]
[backup? #t] [backup? #t]
[on-save-file [on-save-file
(lambda (name format) (lambda (name format)
(set! auto-save-error? #f) (set! auto-save-error? #f)
(if (super-on-save-file name format) (if (super-on-save-file name format)
(begin (begin
(if (and backup? (if (and backup?
(not (= format wx:const-media-ff-copy))) (not (= format wx:const-media-ff-copy)))
(if (file-exists? name) (if (file-exists? name)
(let ([back-name (mred:path-utils^:generate-backup-name name)]) (let ([back-name (mred:path-utils^:generate-backup-name name)])
(unless (file-exists? back-name) (unless (file-exists? back-name)
(rename-file name back-name))))) (rename-file name back-name)))))
#t) #t)
#f))] #f))]
[get-canvas [get-canvas
(lambda () (lambda ()
(cond (cond
[(and active-canvas [(and active-canvas
(member active-canvas canvases)) (member active-canvas canvases))
active-canvas] active-canvas]
[(null? canvases) #f] [(null? canvases) #f]
[else (car canvases)]))] [else (car canvases)]))]
[get-frame [get-frame
(lambda () (lambda ()
(let ([c (get-canvas)]) (let ([c (get-canvas)])
(if c (if c
(let ([f (send c get-parent)]) (let ([f (send c get-parent)])
(if (null? f) (if (null? f)
#f #f
f)) f))
#f)))]) #f)))])
(sequence (sequence
(apply super-init args))))) (apply super-init args)))))
@ -163,18 +161,29 @@
(lambda (super%) (lambda (super%)
(class (make-std-buffer% super%) args (class (make-std-buffer% super%) args
(inherit mode canvases (inherit mode canvases
invalidate-bitmap-cache
begin-edit-sequence end-edit-sequence
flash-on get-keymap get-start-position flash-on get-keymap get-start-position
on-default-char on-default-event on-default-char on-default-event
set-file-format get-style-list) set-file-format get-style-list)
(rename [super-on-focus on-focus] (rename [super-on-focus on-focus]
[super-on-paint on-paint] [super-on-paint on-paint]
[super-after-set-position after-set-position]
[super-on-local-event on-local-event] [super-on-local-event on-local-event]
[super-on-local-char on-local-char] [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-insert on-insert]
[super-on-delete on-delete] [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-insert after-insert]
[super-after-delete after-delete]) [super-after-delete after-delete]
[super-after-set-size-constraint after-set-size-constraint])
(public (public
[set-mode [set-mode
(lambda (m) (lambda (m)
@ -211,6 +220,19 @@
(lambda (start len) (lambda (start len)
(if (or (not mode) (send mode on-delete this start len)) (if (or (not mode) (send mode on-delete this start len))
(super-on-delete 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 [after-insert
(lambda (start len) (lambda (start len)
@ -220,81 +242,122 @@
(lambda (start len) (lambda (start len)
(if mode (send mode after-delete this start len)) (if mode (send mode after-delete this start len))
(super-after-delete 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 [after-set-position
(lambda () (lambda ()
(when mode (when mode
(send mode after-set-position this)) (send mode after-set-position this))
(super-after-set-position))] (super-after-set-position))]
[ranges (list (list 4 24 '... '...))] [ranges null]
[add-range [add-range
(lambda (start end b/w-pattern color-pattern) (lambda (start end pen brush)
(let ([l (list start end b/w-pattern color-pattern)]) (let ([l (make-range start end pen brush)])
(set! ranges (cons l ranges)) (set! ranges (cons l ranges))
(recompute-range-rectangles)
(lambda () (set! ranges (lambda () (set! ranges
(let loop ([r ranges]) (let loop ([r ranges])
(cond (cond
[(null? r) r] [(null? r) r]
[else (if (eq? (car r) l) [else (if (eq? (car r) l)
(cdr r) (cdr r)
(cons (car r) (loop (cdr r))))]))))))] (cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles))))]
[range-rectangles null] [range-rectangles null]
[recompute-range-rectangles [recompute-range-rectangles
(lambda () (lambda ()
(let ([new-rectangles (let ([new-rectangles
(lambda (start end b/w color) (lambda (range)
(let ([left 0] (let ([start (range-start range)]
[right 1000] [end (range-end range)]
[top-start-x (box 0)] [pen (range-pen range)]
[brush (range-brush range)]
[buffer-width (box 0)]
[start-x (box 0)]
[top-start-y (box 0)] [top-start-y (box 0)]
[bottom-start-x (box 0)]
[bottom-start-y (box 0)] [bottom-start-y (box 0)]
[top-end-x (box 0)] [end-x (box 0)]
[top-end-y (box 0)] [top-end-y (box 0)]
[bottom-end-x (box 0)]
[bottom-end-y (box 0)]) [bottom-end-y (box 0)])
(send this position-location start top-start-x top-start-y #t #f #t) (send this get-extent buffer-width null)
(send this position-location end top-end-x top-end-y #t #t #t) (send this position-location start start-x top-start-y #t #f #t)
(send this position-location start bottom-start-x bottom-start-y #f #f #t) (send this position-location end end-x top-end-y #t #t #t)
(send this position-location end bottom-end-x bottom-end-y #f #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 (cond
[(= (unbox top-start-y) (unbox top-end-y)) [(= (unbox top-start-y) (unbox top-end-y))
(list (list (unbox top-start-x) (unbox top-start-y) (list (make-rectangle (unbox start-x)
(- (unbox bottom-end-x) (unbox top-start-x)) (unbox top-start-y)
(- (unbox bottom-end-y) (unbox top-start-y))))] (- (unbox end-x) (unbox start-x))
(- (unbox bottom-start-y) (unbox top-start-y))
pen brush))]
[else [else
(list (list (unbox top-start-x) (unbox top-start-y) (list
(- right (unbox top-start-x)) (make-rectangle (unbox start-x)
(- (unbox bottom-start-y) (unbox top-start-y))) (unbox top-start-y)
(list (unbox bottom-start-x) left (- (unbox buffer-width) (unbox start-x))
(- right left) (- (unbox bottom-start-x) (unbox top-end-x))) (- (unbox bottom-start-y) (unbox top-start-y))
(list left (unbox top-end-y) pen brush)
(- (unbox top-end-x) left) (make-rectangle 0
(- (unbox bottom-end-y) (unbox top-end-y))))])))]) (unbox bottom-start-y)
(set! range-rectangles (map (lambda (x) (apply new-rectangles x)) ranges)) (unbox buffer-width)
(printf "~a~n" range-rectangles)))] (- (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 [on-paint
(lambda (before dc left top right bottom dx dy draw-caret) (lambda (before dc left top right bottom dx dy draw-caret)
(when #f (super-on-paint before dc left top right bottom dx dy draw-caret)
(for-each (lambda (rlist) (unless before
(for-each (lambda (rectangle) (for-each (lambda (rectangle)
(let ([pen (make-object wx:pen% "black" 1 1)] (let ([pen (rectangle-pen rectangle)]
[brush (make-object wx:brush% "black" wx:const-transparent)] [brush (rectangle-brush rectangle)]
[old-pen (send dc get-pen)] [old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]) [old-brush (send dc get-brush)]
(send dc set-pen pen) [left (rectangle-left rectangle)]
(send dc set-brush brush) [top (rectangle-top rectangle)]
(send dc draw-rectangle [width (rectangle-width rectangle)]
(+ (first rectangle) dx) [height (rectangle-height rectangle)])
(+ (second rectangle) dy) (send dc set-pen pen)
(+ (third rectangle) dx) (send dc set-brush brush)
(+ (fourth rectangle) dy)) (unless (or (zero? width)
(send dc set-pen old-pen) (zero? height))
(send dc set-brush old-brush))) (send dc draw-rectangle (+ left dx) (+ top dy) width height))
rlist)) (send dc set-pen old-pen)
range-rectangles)) (send dc set-brush old-brush)))
(super-on-paint before dc left top right bottom dx dy draw-caret))]) range-rectangles)))])
(sequence (sequence
(apply super-init args) (apply super-init args)
(send edits add this) (send edits add this)

12
collects/mred/finder.ss
View File

@ -347,10 +347,10 @@
[filter-msg "That name does not have the right form"]) [filter-msg "That name does not have the right form"])
(let* ([directory (if (and (null? directory) (let* ([directory (if (and (null? directory)
(string? name)) (string? name))
(mzlib:file^:path-only name) (or (mzlib:file^:path-only name) null)
directory)] directory)]
[name (if (string? name) [name (or (and (string? name)
(mzlib:file^:file-name-from-path name) (mzlib:file^:file-name-from-path name))
name)] name)]
[v (box #f)]) [v (box #f)])
(make-object finder-dialog% #t replace? #f v (make-object finder-dialog% #t replace? #f v
@ -382,8 +382,8 @@
(string? name)) (string? name))
(or (mzlib:file^:path-only name) null) (or (mzlib:file^:path-only name) null)
directory)] directory)]
[name (if (string? name) [name (or (and (string? name)
(mzlib:file^:file-name-from-path name) (mzlib:file^:file-name-from-path name))
name)] name)]
[f (wx:file-selector prompt directory name [f (wx:file-selector prompt directory name
'() '()
@ -402,7 +402,7 @@
[(not (and (string? dir) (directory-exists? dir))) [(not (and (string? dir) (directory-exists? dir)))
(wx:message-box "Error" "That directory does not exist.") (wx:message-box "Error" "That directory does not exist.")
#f] #f]
[(equal? name "") [(or (not name) (equal? name ""))
(wx:message-box "Error" "Empty filename.") (wx:message-box "Error" "Empty filename.")
#f] #f]
[else f])))))) [else f]))))))