added paren highlighting and fixed drscheme/quit bug
original commit: c157ca5bc72bd94fa0c9df123805d0294662a941
This commit is contained in:
Robby Findler
parent
f2798942a9
commit
ace788472e
|
|
@ -1,11 +1,9 @@
|
|||
(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%)
|
||||
|
|
@ -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,6 +242,20 @@
|
|||
(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 ()
|
||||
|
|
@ -227,74 +263,101 @@
|
|||
(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)]
|
||||
(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)
|
||||
(super-on-paint before dc left top right bottom dx dy draw-caret)
|
||||
(unless before
|
||||
(for-each (lambda (rectangle)
|
||||
(let ([pen (make-object wx:pen% "black" 1 1)]
|
||||
[brush (make-object wx:brush% "black" wx:const-transparent)]
|
||||
(let ([pen (rectangle-pen rectangle)]
|
||||
[brush (rectangle-brush rectangle)]
|
||||
[old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)])
|
||||
[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)
|
||||
(send dc draw-rectangle
|
||||
(+ (first rectangle) dx)
|
||||
(+ (second rectangle) dy)
|
||||
(+ (third rectangle) dx)
|
||||
(+ (fourth rectangle) dy))
|
||||
(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)))
|
||||
rlist))
|
||||
range-rectangles))
|
||||
(super-on-paint before dc left top right bottom dx dy draw-caret))])
|
||||
range-rectangles)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(send edits add this)
|
||||
|
|
|
|||
|
|
@ -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]))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user