no message

original commit: 4398b7e60e92fd77bf49d28429dadf08b8b9f2d4
This commit is contained in:
Robby Findler 2001-03-29 21:45:05 +00:00
parent 55ec7d4505
commit 614c0a9e8d
6 changed files with 534 additions and 521 deletions

View File

@ -109,7 +109,7 @@
(rename [super-begin-edit-sequence begin-edit-sequence]
[super-end-edit-sequence end-edit-sequence])
(private
(private-field
[edit-sequence-count 0])
(override
[begin-edit-sequence
@ -126,7 +126,7 @@
(super-end-edit-sequence))])
(public
[on-close void]
[on-close (lambda () (void))]
[get-top-level-window
(lambda ()
(let loop ([text this])
@ -143,7 +143,7 @@
(public [editing-this-file? (lambda () #f)])
(private
(private-field
[edit-sequence-queue null]
[edit-sequence-ht (make-hash-table)])
@ -277,7 +277,7 @@
(auto-wrap
(preferences:get
'framework:auto-set-wrap?)))
(private
(private-field
[remove-callback
(preferences:add-callback
'framework:auto-set-wrap?
@ -398,7 +398,7 @@
(lambda ()
(super-on-close)
(remove-autosave)
(set! autosave? (lambda () #f)))]
(set! do-autosave? #f))]
[on-change
(lambda ()
(super-on-change)
@ -410,8 +410,10 @@
(set! auto-save-out-of-date? #t)
(remove-autosave)))
(super-set-modified modified?))])
(private-field
[do-autosave? #t])
(public
[autosave? (lambda () #t)]
[autosave? (lambda () do-autosave?)]
[do-autosave
(lambda ()
(when (and (autosave?)

View File

@ -1330,10 +1330,6 @@
[pos (if (eq? searching-direction 'forward)
(send replacee-edit get-start-position)
(send replacee-edit get-end-position))]
[get-pos
(if (eq? searching-direction 'forward)
(ivar replacee-edit get-end-position)
(ivar replacee-edit get-start-position))]
[done? (if (eq? 'forward searching-direction)
(lambda (x) (>= x (send replacee-edit last-position)))
(lambda (x) (<= x 0)))])

View File

@ -98,7 +98,7 @@
(let* ([set-close-menu-item-state!
(lambda (frame state)
(when (is-a? frame frame:standard-menus<%>)
(let ([close-menu-item (ivar frame file-menu:close-menu)])
(let ([close-menu-item (send frame file-menu:get-close-menu)])
(when close-menu-item
(send close-menu-item enable state)))))])
(if (eq? (length frames) 1)

View File

@ -829,124 +829,133 @@
(define setup-keymap
(lambda (keymap)
(let ([add-pos-function
(lambda (name ivar-sym)
(send keymap add-function name
(lambda (edit event)
((ivar/proc edit ivar-sym)
(send edit get-start-position)))))])
(add-pos-function "remove-sexp" 'remove-sexp)
(add-pos-function "forward-sexp" 'forward-sexp)
(add-pos-function "backward-sexp" 'backward-sexp)
(add-pos-function "up-sexp" 'up-sexp)
(add-pos-function "down-sexp" 'down-sexp)
(add-pos-function "flash-backward-sexp" 'flash-backward-sexp)
(add-pos-function "flash-forward-sexp" 'flash-forward-sexp)
(add-pos-function "remove-parens-forward" 'remove-parens-forward)
(add-pos-function "transpose-sexp" 'transpose-sexp))
(let ([add-edit-function
(lambda (name ivar-sym)
(send keymap add-function name
(lambda (edit event)
((ivar/proc edit ivar-sym)))))])
(add-edit-function "select-forward-sexp" 'select-forward-sexp)
(add-edit-function "select-backward-sexp" 'select-backward-sexp)
(add-edit-function "select-down-sexp" 'select-down-sexp)
(add-edit-function "select-up-sexp" 'select-up-sexp)
(add-edit-function "tabify-at-caret" 'tabify-selection)
(add-edit-function "do-return" 'insert-return)
(add-edit-function "comment-out" 'comment-out-selection)
(add-edit-function "uncomment" 'uncomment-selection))
(send keymap add-function "balance-parens"
(lambda (edit event)
(send edit balance-parens event)))
(send keymap add-function "balance-quotes"
(lambda (edit event)
(send edit balance-quotes event)))
(send keymap map-function "TAB" "tabify-at-caret")
(send keymap map-function "return" "do-return")
(send keymap map-function "s:return" "do-return")
(send keymap map-function "s:c:return" "do-return")
(send keymap map-function "a:return" "do-return")
(send keymap map-function "s:a:return" "do-return")
(send keymap map-function "c:a:return" "do-return")
(send keymap map-function "c:s:a:return" "do-return")
(send keymap map-function "c:return" "do-return")
(send keymap map-function "d:return" "do-return")
(send keymap map-function ")" "balance-parens")
(send keymap map-function "]" "balance-parens")
(send keymap map-function "}" "balance-parens")
(send keymap map-function "\"" "balance-quotes")
(send keymap map-function "|" "balance-quotes")
;(send keymap map-function "c:up" "up-sexp") ;; paragraph
;(send keymap map-function "s:c:up" "select-up-sexp")
;(send keymap map-function "c:down" "down-sexp") ;; paragraph
;(send keymap map-function "s:c:down" "select-down-sexp")
(let ([map-meta
(lambda (key func)
(keymap:send-map-function-meta keymap key func))]
[map
(lambda (key func)
(send keymap map-function key func))])
(map-meta "up" "up-sexp")
(map-meta "c:u" "up-sexp")
(map "a:up" "up-sexp")
(map-meta "s:up" "select-up-sexp")
(map "a:s:up" "select-up-sexp")
(map-meta "s:c:u" "select-up-sexp")
(map-meta "down" "down-sexp")
(map "a:down" "down-sexp")
(map-meta "c:down" "down-sexp")
(map-meta "s:down" "select-down-sexp")
(map "a:s:down" "select-down-sexp")
(map-meta "s:c:down" "select-down-sexp")
(map-meta "right" "forward-sexp")
(map "a:right" "forward-sexp")
(map-meta "s:right" "select-forward-sexp")
(map "a:s:right" "select-forward-sexp")
(map-meta "left" "backward-sexp")
(map "a:left" "backward-sexp")
(map-meta "s:left" "select-backward-sexp")
(map "a:s:left" "select-backward-sexp")
(map-meta "return" "do-return")
(map-meta "s:return" "do-return")
(map-meta "s:c:return" "do-return")
(map-meta "a:return" "do-return")
(map-meta "s:a:return" "do-return")
(map-meta "c:a:return" "do-return")
(map-meta "c:s:a:return" "do-return")
(map-meta "c:return" "do-return")
(map-meta "c:semicolon" "comment-out")
(map-meta "c:=" "uncomment")
(map-meta "c:k" "remove-sexp")
(map-meta "c:f" "forward-sexp")
(map-meta "s:c:f" "select-forward-sexp")
(map-meta "c:b" "backward-sexp")
(map-meta "s:c:b" "select-backward-sexp")
(map-meta "c:p" "flash-backward-sexp")
(map-meta "s:c:n" "flash-forward-sexp")
(map-meta "c:space" "select-forward-sexp")
(map-meta "c:t" "transpose-sexp"))
(send keymap map-function "c:c;c:b" "remove-parens-forward")))
(let ([add-pos-function
(lambda (name call-method)
(send keymap add-function name
(lambda (edit event)
(call-method
edit
(send edit get-start-position)))))])
(add-pos-function "remove-sexp" (lambda (e p) (send e remove-sexp p)))
(add-pos-function "forward-sexp" (lambda (e p) (send e forward-sexp p)))
(add-pos-function "backward-sexp" (lambda (e p) (send e backward-sexp p)))
(add-pos-function "up-sexp" (lambda (e p) (send e up-sexp p)))
(add-pos-function "down-sexp" (lambda (e p) (send e down-sexp p)))
(add-pos-function "flash-backward-sexp" (lambda (e p) (send e flash-backward-sexp p)))
(add-pos-function "flash-forward-sexp" (lambda (e p) (send e flash-forward-sexp p)))
(add-pos-function "remove-parens-forward" (lambda (e p) (send e remove-parens-forward p)))
(add-pos-function "transpose-sexp" (lambda (e p) (send e transpose-sexp p))))
(let ([add-edit-function
(lambda (name call-method)
(send keymap add-function name
(lambda (edit event)
(call-method edit))))])
(add-edit-function "select-forward-sexp"
(lambda (x) (send x select-forward-sexp)))
(add-edit-function "select-backward-sexp"
(lambda (x) (send x select-backward-sexp)))
(add-edit-function "select-down-sexp"
(lambda (x) (send x select-down-sexp)))
(add-edit-function "select-up-sexp"
(lambda (x) (send x select-up-sexp)))
(add-edit-function "tabify-at-caret"
(lambda (x) (send x tabify-selection)))
(add-edit-function "do-return"
(lambda (x) (send x insert-return)))
(add-edit-function "comment-out"
(lambda (x) (send x comment-out-selection)))
(add-edit-function "uncomment"
(lambda (x) (send x uncomment-selection))))
(send keymap add-function "balance-parens"
(lambda (edit event)
(send edit balance-parens event)))
(send keymap add-function "balance-quotes"
(lambda (edit event)
(send edit balance-quotes event)))
(send keymap map-function "TAB" "tabify-at-caret")
(send keymap map-function "return" "do-return")
(send keymap map-function "s:return" "do-return")
(send keymap map-function "s:c:return" "do-return")
(send keymap map-function "a:return" "do-return")
(send keymap map-function "s:a:return" "do-return")
(send keymap map-function "c:a:return" "do-return")
(send keymap map-function "c:s:a:return" "do-return")
(send keymap map-function "c:return" "do-return")
(send keymap map-function "d:return" "do-return")
(send keymap map-function ")" "balance-parens")
(send keymap map-function "]" "balance-parens")
(send keymap map-function "}" "balance-parens")
(send keymap map-function "\"" "balance-quotes")
(send keymap map-function "|" "balance-quotes")
;(send keymap map-function "c:up" "up-sexp") ;; paragraph
;(send keymap map-function "s:c:up" "select-up-sexp")
;(send keymap map-function "c:down" "down-sexp") ;; paragraph
;(send keymap map-function "s:c:down" "select-down-sexp")
(let ([map-meta
(lambda (key func)
(keymap:send-map-function-meta keymap key func))]
[map
(lambda (key func)
(send keymap map-function key func))])
(map-meta "up" "up-sexp")
(map-meta "c:u" "up-sexp")
(map "a:up" "up-sexp")
(map-meta "s:up" "select-up-sexp")
(map "a:s:up" "select-up-sexp")
(map-meta "s:c:u" "select-up-sexp")
(map-meta "down" "down-sexp")
(map "a:down" "down-sexp")
(map-meta "c:down" "down-sexp")
(map-meta "s:down" "select-down-sexp")
(map "a:s:down" "select-down-sexp")
(map-meta "s:c:down" "select-down-sexp")
(map-meta "right" "forward-sexp")
(map "a:right" "forward-sexp")
(map-meta "s:right" "select-forward-sexp")
(map "a:s:right" "select-forward-sexp")
(map-meta "left" "backward-sexp")
(map "a:left" "backward-sexp")
(map-meta "s:left" "select-backward-sexp")
(map "a:s:left" "select-backward-sexp")
(map-meta "return" "do-return")
(map-meta "s:return" "do-return")
(map-meta "s:c:return" "do-return")
(map-meta "a:return" "do-return")
(map-meta "s:a:return" "do-return")
(map-meta "c:a:return" "do-return")
(map-meta "c:s:a:return" "do-return")
(map-meta "c:return" "do-return")
(map-meta "c:semicolon" "comment-out")
(map-meta "c:=" "uncomment")
(map-meta "c:k" "remove-sexp")
(map-meta "c:f" "forward-sexp")
(map-meta "s:c:f" "select-forward-sexp")
(map-meta "c:b" "backward-sexp")
(map-meta "s:c:b" "select-backward-sexp")
(map-meta "c:p" "flash-backward-sexp")
(map-meta "s:c:n" "flash-forward-sexp")
(map-meta "c:space" "select-forward-sexp")
(map-meta "c:t" "transpose-sexp"))
(send keymap map-function "c:c;c:b" "remove-parens-forward")))
(define keymap (make-object keymap:aug-keymap%))
(setup-keymap keymap)

View File

@ -39,307 +39,306 @@
(define basic-mixin
(mixin (editor:basic<%> (class->interface text%)) (basic<%>) args
(inherit get-canvases get-admin split-snip get-snip-position
begin-edit-sequence end-edit-sequence
set-autowrap-bitmap
delete find-snip invalidate-bitmap-cache
set-file-format get-file-format
get-style-list is-modified? change-style set-modified
position-location get-extent)
(private
[b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)]
[range-rectangles null]
[invalidate-rectangles
(lambda (rectangles)
(let-values
([(min-left max-right)
(let loop ([left #f]
[right #f]
[canvases (get-canvases)])
(cond
[(null? canvases)
(values left right)]
[else
(let-values ([(this-left this-right)
(send (car canvases)
call-as-primary-owner
(lambda ()
(send (get-admin) get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
[this-right (+ this-left this-width)])
(values this-left
this-right))))])
(if (and left right)
(loop (min this-left left)
(max this-right right)
(cdr canvases))
(loop this-left
this-right
(cdr canvases))))]))])
(when (and min-left max-right)
(let loop ([left #f]
[top #f]
[right #f]
[bottom #f]
[rectangles rectangles])
(cond
[(null? rectangles)
(when left
(let ([width (- right left)]
[height (- bottom top)])
(when (and (> width 0)
(> height 0))
(invalidate-bitmap-cache left top width height))))]
[else (let* ([r (car rectangles)]
[rleft (rectangle-left r)]
[rright (rectangle-right r)]
[rtop (rectangle-top r)]
[rbottom (rectangle-bottom r)]
[this-left (if (number? rleft)
rleft
min-left)]
[this-right (if (number? rright)
rright
max-right)]
[this-bottom rbottom]
[this-top rtop])
(if (and left top right bottom)
(loop (min this-left left)
(min this-top top)
(max this-right right)
(max this-bottom bottom)
(cdr rectangles))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles))))])))))]
[recompute-range-rectangles
(lambda ()
(let ([new-rectangles
(lambda (range)
(let* ([start (range-start range)]
[end (range-end range)]
[b/w-bitmap (range-b/w-bitmap range)]
[color (range-color range)]
[caret-space? (range-caret-space? range)]
[start-eol? #f]
[end-eol? (if (= start end)
start-eol?
#t)])
(let-values ([(start-x top-start-y)
(begin
(position-location start b1 b2 #t start-eol? #t)
(values (if caret-space?
(+ 1 (unbox b1))
(unbox b1))
(unbox b2)))]
[(end-x top-end-y)
(begin (position-location end b1 b2 #t end-eol? #t)
(values (unbox b1) (unbox b2)))]
[(bottom-start-y)
(begin (position-location start b1 b2 #f start-eol? #t)
(unbox b2))]
[(bottom-end-y)
(begin (position-location end b1 b2 #f end-eol? #t)
(unbox b2))])
(cond
[(= top-start-y top-end-y)
(list
(make-rectangle start-x
top-start-y
(if (= end-x start-x)
(+ end-x 1)
end-x)
bottom-start-y
b/w-bitmap
color))]
[else
(list
(make-rectangle start-x
top-start-y
'right-edge
bottom-start-y
b/w-bitmap
color)
(make-rectangle 'left-edge
bottom-start-y
'max-width
top-end-y
b/w-bitmap
color)
(make-rectangle 'left-edge
top-end-y
end-x
bottom-end-y
b/w-bitmap
color))]))))]
[old-rectangles range-rectangles])
(set! range-rectangles
(foldl (lambda (x l) (append (new-rectangles x) l))
null ranges))))]
[ranges null]
[pen (make-object pen% "BLACK" 0 'solid)]
[brush (make-object brush% "black" 'solid)])
(public
(inherit get-canvases get-admin split-snip get-snip-position
begin-edit-sequence end-edit-sequence
set-autowrap-bitmap
delete find-snip invalidate-bitmap-cache
set-file-format get-file-format
get-style-list is-modified? change-style set-modified
position-location get-extent)
(private-field
[b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)]
[range-rectangles null]
[ranges null]
[pen (make-object pen% "BLACK" 0 'solid)]
[brush (make-object brush% "black" 'solid)])
(private
[invalidate-rectangles
(lambda (rectangles)
(let-values
([(min-left max-right)
(let loop ([left #f]
[right #f]
[canvases (get-canvases)])
(cond
[(null? canvases)
(values left right)]
[else
(let-values ([(this-left this-right)
(send (car canvases)
call-as-primary-owner
(lambda ()
(send (get-admin) get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
[this-right (+ this-left this-width)])
(values this-left
this-right))))])
(if (and left right)
(loop (min this-left left)
(max this-right right)
(cdr canvases))
(loop this-left
this-right
(cdr canvases))))]))])
(when (and min-left max-right)
(let loop ([left #f]
[top #f]
[right #f]
[bottom #f]
[rectangles rectangles])
(cond
[(null? rectangles)
(when left
(let ([width (- right left)]
[height (- bottom top)])
(when (and (> width 0)
(> height 0))
(invalidate-bitmap-cache left top width height))))]
[else (let* ([r (car rectangles)]
[rleft (rectangle-left r)]
[rright (rectangle-right r)]
[rtop (rectangle-top r)]
[rbottom (rectangle-bottom r)]
[this-left (if (number? rleft)
rleft
min-left)]
[this-right (if (number? rright)
rright
max-right)]
[this-bottom rbottom]
[this-top rtop])
(if (and left top right bottom)
(loop (min this-left left)
(min this-top top)
(max this-right right)
(max this-bottom bottom)
(cdr rectangles))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles))))])))))]
[recompute-range-rectangles
(lambda ()
(let ([new-rectangles
(lambda (range)
(let* ([start (range-start range)]
[end (range-end range)]
[b/w-bitmap (range-b/w-bitmap range)]
[color (range-color range)]
[caret-space? (range-caret-space? range)]
[start-eol? #f]
[end-eol? (if (= start end)
start-eol?
#t)])
(let-values ([(start-x top-start-y)
(begin
(position-location start b1 b2 #t start-eol? #t)
(values (if caret-space?
(+ 1 (unbox b1))
(unbox b1))
(unbox b2)))]
[(end-x top-end-y)
(begin (position-location end b1 b2 #t end-eol? #t)
(values (unbox b1) (unbox b2)))]
[(bottom-start-y)
(begin (position-location start b1 b2 #f start-eol? #t)
(unbox b2))]
[(bottom-end-y)
(begin (position-location end b1 b2 #f end-eol? #t)
(unbox b2))])
(cond
[(= top-start-y top-end-y)
(list
(make-rectangle start-x
top-start-y
(if (= end-x start-x)
(+ end-x 1)
end-x)
bottom-start-y
b/w-bitmap
color))]
[else
(list
(make-rectangle start-x
top-start-y
'right-edge
bottom-start-y
b/w-bitmap
color)
(make-rectangle 'left-edge
bottom-start-y
'max-width
top-end-y
b/w-bitmap
color)
(make-rectangle 'left-edge
top-end-y
end-x
bottom-end-y
b/w-bitmap
color))]))))]
[old-rectangles range-rectangles])
(set! range-rectangles
(foldl (lambda (x l) (append (new-rectangles x) l))
null ranges))))])
(public
;; the bitmap is used in b/w and the color is used in color.
[highlight-range
(opt-lambda (start end color bitmap [caret-space? #f] [priority 'low])
(let ([l (make-range start end bitmap color caret-space?)])
(unless (or (eq? priority 'high) (eq? priority 'low))
(error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
priority))
(invalidate-rectangles range-rectangles)
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles)
(lambda ()
(let ([old-rectangles range-rectangles])
(set! ranges
(let loop ([r ranges])
(cond
[(null? r) r]
[else (if (eq? (car r) l)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles)
(invalidate-rectangles old-rectangles)))))])
(rename [super-on-paint on-paint])
(override
[on-paint
(lambda (before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(recompute-range-rectangles)
(for-each
(lambda (rectangle)
(let-values ([(view-x view-y view-width view-height)
(begin
(send (get-admin) get-view b1 b2 b3 b4)
(values (unbox b1)
(unbox b2)
(unbox b3)
(unbox b4)))])
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[color (let* ([rc (rectangle-color rectangle)]
[tmpc (make-object color% 0 0 0)])
(if rc
(begin (send dc try-color rc tmpc)
(if (<= (color-model:rgb-color-distance
(send rc red)
(send rc green)
(send rc blue)
(send tmpc red)
(send tmpc green)
(send tmpc blue))
18)
rc
#f))
rc))]
[first-number (lambda (x y) (if (number? x) x y))]
[left (max left-margin (first-number (rectangle-left rectangle) view-x))]
[top (max top-margin (rectangle-top rectangle))]
[right (min right-margin
(if (number? (rectangle-right rectangle))
(rectangle-right rectangle)
(+ view-x view-width)))]
[bottom (min bottom-margin (rectangle-bottom rectangle))]
[width (max 0 (- right left))]
[height (max 0 (- bottom top))])
(let/ec k
(cond
[(and before color)
(send pen set-color color)
(send brush set-color color)]
[(and (not before) (not color) b/w-bitmap)
(send pen set-stipple b/w-bitmap)
(send brush set-stipple b/w-bitmap)]
[else (k (void))])
(send dc set-pen pen)
(send dc set-brush brush)
(send dc draw-rectangle
(+ left dx)
(+ top dy)
width
height)
(send dc set-pen old-pen)
(send dc set-brush old-brush)))))
range-rectangles))])
(private
[styles-fixed? #f]
[styles-fixed-edit-modified? #f])
(public
[get-styles-fixed (lambda () styles-fixed?)]
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
(rename
[super-on-change-style on-change-style]
[super-after-change-style after-change-style]
[super-on-insert on-insert]
[super-after-insert after-insert])
(override
[on-change-style
(lambda (start len)
(when styles-fixed?
(set! styles-fixed-edit-modified? (is-modified?)))
(super-on-change-style start len))]
[on-insert
(lambda (start len)
(begin-edit-sequence)
(super-on-insert start len))]
[after-insert
(lambda (start len)
(when styles-fixed?
(change-style (send (get-style-list) find-named-style "Standard")
start
(+ start len)))
(super-after-insert start len)
(end-edit-sequence))]
[after-change-style
(lambda (start len)
(super-after-change-style start len)
(when styles-fixed?
(set-modified styles-fixed-edit-modified?)))])
(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 'before)])
(cond
[(or (not 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))])
(insert-edit released/copied dest-position dest-position)
(loop prev))]))))])
(public
[initial-autowrap-bitmap (lambda () (icon:get-autowrap-bitmap))])
(sequence
(apply super-init args)
(set-autowrap-bitmap (initial-autowrap-bitmap)))))
[highlight-range
(opt-lambda (start end color bitmap [caret-space? #f] [priority 'low])
(let ([l (make-range start end bitmap color caret-space?)])
(unless (or (eq? priority 'high) (eq? priority 'low))
(error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
priority))
(invalidate-rectangles range-rectangles)
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles)
(lambda ()
(let ([old-rectangles range-rectangles])
(set! ranges
(let loop ([r ranges])
(cond
[(null? r) r]
[else (if (eq? (car r) l)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles)
(invalidate-rectangles old-rectangles)))))])
(rename [super-on-paint on-paint])
(override
[on-paint
(lambda (before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(recompute-range-rectangles)
(for-each
(lambda (rectangle)
(let-values ([(view-x view-y view-width view-height)
(begin
(send (get-admin) get-view b1 b2 b3 b4)
(values (unbox b1)
(unbox b2)
(unbox b3)
(unbox b4)))])
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[color (let* ([rc (rectangle-color rectangle)]
[tmpc (make-object color% 0 0 0)])
(if rc
(begin (send dc try-color rc tmpc)
(if (<= (color-model:rgb-color-distance
(send rc red)
(send rc green)
(send rc blue)
(send tmpc red)
(send tmpc green)
(send tmpc blue))
18)
rc
#f))
rc))]
[first-number (lambda (x y) (if (number? x) x y))]
[left (max left-margin (first-number (rectangle-left rectangle) view-x))]
[top (max top-margin (rectangle-top rectangle))]
[right (min right-margin
(if (number? (rectangle-right rectangle))
(rectangle-right rectangle)
(+ view-x view-width)))]
[bottom (min bottom-margin (rectangle-bottom rectangle))]
[width (max 0 (- right left))]
[height (max 0 (- bottom top))])
(let/ec k
(cond
[(and before color)
(send pen set-color color)
(send brush set-color color)]
[(and (not before) (not color) b/w-bitmap)
(send pen set-stipple b/w-bitmap)
(send brush set-stipple b/w-bitmap)]
[else (k (void))])
(send dc set-pen pen)
(send dc set-brush brush)
(send dc draw-rectangle
(+ left dx)
(+ top dy)
width
height)
(send dc set-pen old-pen)
(send dc set-brush old-brush)))))
range-rectangles))])
(private-field
[styles-fixed? #f]
[styles-fixed-edit-modified? #f])
(public
[get-styles-fixed (lambda () styles-fixed?)]
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
(rename
[super-on-change-style on-change-style]
[super-after-change-style after-change-style]
[super-on-insert on-insert]
[super-after-insert after-insert])
(override
[on-change-style
(lambda (start len)
(when styles-fixed?
(set! styles-fixed-edit-modified? (is-modified?)))
(super-on-change-style start len))]
[on-insert
(lambda (start len)
(begin-edit-sequence)
(super-on-insert start len))]
[after-insert
(lambda (start len)
(when styles-fixed?
(change-style (send (get-style-list) find-named-style "Standard")
start
(+ start len)))
(super-after-insert start len)
(end-edit-sequence))]
[after-change-style
(lambda (start len)
(super-after-change-style start len)
(when styles-fixed?
(set-modified styles-fixed-edit-modified?)))])
(public
[move/copy-to-edit
(lambda (dest-edit start end dest-position)
(split-snip start)
(split-snip end)
(let loop ([snip (find-snip end 'before)])
(cond
[(or (not 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))])
(send dest-edit insert released/copied dest-position dest-position)
(loop prev))])))])
(public
[initial-autowrap-bitmap (lambda () (icon:get-autowrap-bitmap))])
(sequence
(apply super-init args)
(set-autowrap-bitmap (initial-autowrap-bitmap)))))
(define searching<%> (interface (editor:keymap<%> basic<%>)))
(define searching-mixin
@ -366,75 +365,81 @@
(define return<%> (interface ((class->interface text%))))
(define return-mixin
(mixin ((class->interface text%)) (return<%>) (return . args)
(rename [super-on-local-char on-local-char])
(override
[on-local-char
(lambda (key)
(let ([cr-code #\return]
[lf-code #\newline]
[code (send key get-key-code)])
(or (and (char? code)
(or (char=? lf-code code)
(char=? cr-code code))
(return))
(super-on-local-char key))))])
(sequence
(apply super-init args))))
(mixin ((class->interface text%)) (return<%>) (_return . args)
(rename [super-on-local-char on-local-char])
(private-field [return _return])
(override
[on-local-char
(lambda (key)
(let ([cr-code #\return]
[lf-code #\newline]
[code (send key get-key-code)])
(or (and (char? code)
(or (char=? lf-code code)
(char=? cr-code code))
(return))
(super-on-local-char key))))])
(sequence
(apply super-init args))))
(define info<%> (interface (basic<%>)))
(define info-mixin
(mixin (editor:keymap<%> basic<%>) (info<%>) args
(inherit get-start-position get-end-position get-canvas
run-after-edit-sequence)
(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-set-overwrite-mode set-overwrite-mode]
[super-set-anchor set-anchor])
(private
[enqueue-for-frame
(lambda (ivar-sym tag)
(run-after-edit-sequence
(rec from-enqueue-for-frame
(lambda ()
(let ([canvas (get-canvas)])
(when canvas
(let ([frame (send canvas get-top-level-window)])
(when (is-a? frame frame:text-info<%>)
((ivar/proc frame ivar-sym))))))))
tag))])
(override
[set-anchor
(lambda (x)
(super-set-anchor x)
(enqueue-for-frame 'anchor-status-changed
'framework:anchor-status-changed))]
[set-overwrite-mode
(lambda (x)
(super-set-overwrite-mode x)
(enqueue-for-frame 'overwrite-status-changed
'framework:overwrite-status-changed))]
[after-set-position
(lambda ()
(super-after-set-position)
(enqueue-for-frame 'editor-position-changed
'framework:editor-position-changed))]
[after-insert
(lambda (start len)
(super-after-insert start len)
(enqueue-for-frame 'editor-position-changed
'framework:editor-position-changed))]
[after-delete
(lambda (start len)
(super-after-delete start len)
(enqueue-for-frame 'editor-position-changed
'framework:editor-position-changed))])
(sequence
(apply super-init args))))
(inherit get-start-position get-end-position get-canvas
run-after-edit-sequence)
(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-set-overwrite-mode set-overwrite-mode]
[super-set-anchor set-anchor])
(private
[enqueue-for-frame
(lambda (call-method tag)
(run-after-edit-sequence
(rec from-enqueue-for-frame
(lambda ()
(let ([canvas (get-canvas)])
(when canvas
(let ([frame (send canvas get-top-level-window)])
(when (is-a? frame frame:text-info<%>)
(call-method frame)))))))
tag))])
(override
[set-anchor
(lambda (x)
(super-set-anchor x)
(enqueue-for-frame
(lambda (x) (send x anchor-status-changed))
'framework:anchor-status-changed))]
[set-overwrite-mode
(lambda (x)
(super-set-overwrite-mode x)
(enqueue-for-frame
(lambda (x) (send x overwrite-status-changed))
'framework:overwrite-status-changed))]
[after-set-position
(lambda ()
(super-after-set-position)
(enqueue-for-frame
(lambda (x) (send x editor-position-changed))
'framework:editor-position-changed))]
[after-insert
(lambda (start len)
(super-after-insert start len)
(enqueue-for-frame
(lambda (x) (send x editor-position-changed))
'framework:editor-position-changed))]
[after-delete
(lambda (start len)
(super-after-delete start len)
(enqueue-for-frame
(lambda (x) (send x editor-position-changed))
'framework:editor-position-changed))])
(sequence
(apply super-init args))))
(define clever-file-format<%> (interface ((class->interface text%))))
@ -442,35 +447,36 @@
(mixin ((class->interface text%)) (clever-file-format<%>) args
(inherit get-file-format set-file-format find-first-snip)
(rename [super-on-save-file on-save-file])
(private
[all-string-snips
(lambda ()
(let loop ([s (find-first-snip)])
(cond
[(not s) #t]
[(is-a? s string-snip%)
(loop (send s next))]
[else #f])))])
(override
[on-save-file
(let ([all-string-snips
(lambda ()
(let loop ([s (find-first-snip)])
(cond
[(not s) #t]
[(is-a? s string-snip%)
(loop (send s next))]
[else #f])))])
(lambda (name format)
(let ([all-strings? (all-string-snips)])
(cond
[(and all-strings?
(or (eq? format 'same) (eq? format 'copy))
(eq? 'standard (get-file-format))
(or (not (preferences:get 'framework:verify-change-format))
(gui-utils:get-choice
"Save this file as plain text?" "Yes" "No")))
(set-file-format 'text)]
[(and (not all-strings?)
(or (eq? format 'same) (eq? format 'copy))
(eq? 'text (get-file-format))
(or (not (preferences:get 'framework:verify-change-format))
(gui-utils:get-choice
"Save this file in drscheme-specific non-text format?" "Yes" "No")))
(set-file-format 'standard)]
[else (void)]))
(super-on-save-file name format)))])
[on-save-file
(lambda (name format)
(let ([all-strings? (all-string-snips)])
(cond
[(and all-strings?
(or (eq? format 'same) (eq? format 'copy))
(eq? 'standard (get-file-format))
(or (not (preferences:get 'framework:verify-change-format))
(gui-utils:get-choice
"Save this file as plain text?" "Yes" "No")))
(set-file-format 'text)]
[(and (not all-strings?)
(or (eq? format 'same) (eq? format 'copy))
(eq? 'text (get-file-format))
(or (not (preferences:get 'framework:verify-change-format))
(gui-utils:get-choice
"Save this file in drscheme-specific non-text format?" "Yes" "No")))
(set-file-format 'standard)]
[else (void)]))
(super-on-save-file name format))])
(sequence
(apply super-init args))))