843 lines
38 KiB
Scheme
843 lines
38 KiB
Scheme
|
|
(module text mzscheme
|
|
(require (lib "string-constant.ss" "string-constants")
|
|
(lib "unitsig.ss")
|
|
(lib "class.ss")
|
|
(lib "class100.ss")
|
|
"sig.ss"
|
|
"../macro.ss"
|
|
"../gui-utils.ss"
|
|
(lib "mred-sig.ss" "mred")
|
|
(lib "list.ss")
|
|
(lib "etc.ss"))
|
|
(provide text@)
|
|
|
|
(define text@
|
|
(unit/sig framework:text^
|
|
(import mred^
|
|
[icon : framework:icon^]
|
|
[editor : framework:editor^]
|
|
[preferences : framework:preferences^]
|
|
[keymap : framework:keymap^]
|
|
[color-model : framework:color-model^]
|
|
[frame : framework:frame^]
|
|
[scheme : framework:scheme^])
|
|
|
|
(rename [-keymap% keymap%])
|
|
|
|
(define-struct range (start end b/w-bitmap color caret-space?))
|
|
(define-struct rectangle (left top right bottom b/w-bitmap color))
|
|
|
|
;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap,
|
|
;; unless matthew makes it primitive
|
|
|
|
(define basic<%>
|
|
(interface (editor:basic<%> (class->interface text%))
|
|
highlight-range
|
|
get-highlighted-ranges
|
|
get-styles-fixed
|
|
set-styles-fixed
|
|
move/copy-to-edit
|
|
initial-autowrap-bitmap))
|
|
|
|
(define basic-mixin
|
|
(mixin (editor:basic<%> (class->interface text%)) (basic<%>)
|
|
(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)
|
|
|
|
(define highlight-pen #f)
|
|
(define highlight-brush #f)
|
|
|
|
(define range-rectangles null)
|
|
(define ranges null)
|
|
|
|
(define/public (get-highlighted-ranges) ranges)
|
|
|
|
(define (invalidate-rectangles rectangles)
|
|
(let ([b1 (box 0)]
|
|
[b2 (box 0)]
|
|
[b3 (box 0)]
|
|
[b4 (box 0)]
|
|
[canvases (get-canvases)])
|
|
(let-values ([(min-left max-right)
|
|
(cond
|
|
[(null? canvases)
|
|
(let ([admin (get-admin)])
|
|
(if admin
|
|
(begin
|
|
(send 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)))
|
|
(values #f #f)))]
|
|
[else
|
|
(let loop ([left #f]
|
|
[right #f]
|
|
[canvases 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))))]))))))
|
|
|
|
(define (recompute-range-rectangles)
|
|
(let* ([b1 (box 0)]
|
|
[b2 (box 0)]
|
|
[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))))
|
|
|
|
(define/public highlight-range
|
|
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
|
|
(unless (let ([exact-pos-int?
|
|
(lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))])
|
|
(and (exact-pos-int? start)
|
|
(exact-pos-int? end)))
|
|
(error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e"
|
|
start end))
|
|
(unless (or (eq? priority 'high) (eq? priority 'low))
|
|
(error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
|
|
priority))
|
|
(let ([l (make-range start end bitmap color caret-space?)])
|
|
(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)
|
|
(define (on-paint 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)
|
|
(let ([b1 (box 0)]
|
|
[b2 (box 0)]
|
|
[b3 (box 0)]
|
|
[b4 (box 0)])
|
|
(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
|
|
(first-number
|
|
(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 dc set-pen (send the-pen-list find-or-create-pen color 0 'solid))
|
|
(send dc set-brush (send the-brush-list find-or-create-brush color 'solid))]
|
|
[(and (not before) (not color) b/w-bitmap)
|
|
(unless highlight-pen
|
|
(set! highlight-pen (make-object pen% "BLACK" 0 'solid)))
|
|
(unless highlight-brush
|
|
(set! highlight-brush (make-object brush% "black" 'solid)))
|
|
(send highlight-pen set-stipple b/w-bitmap)
|
|
(send highlight-brush set-stipple b/w-bitmap)
|
|
(send dc set-pen highlight-pen)
|
|
(send dc set-brush highlight-brush)]
|
|
[else (k (void))])
|
|
(send dc draw-rectangle (+ left dx) (+ top dy) width height)
|
|
(send dc set-pen old-pen)
|
|
(send dc set-brush old-brush)))))
|
|
range-rectangles)))
|
|
|
|
(define styles-fixed? #f)
|
|
(public get-styles-fixed set-styles-fixed)
|
|
(define (get-styles-fixed) styles-fixed?)
|
|
(define (set-styles-fixed b) (set! styles-fixed? b))
|
|
|
|
(rename [super-on-insert on-insert]
|
|
[super-after-insert after-insert])
|
|
(define/override (on-insert start len)
|
|
(begin-edit-sequence)
|
|
(super-on-insert start len))
|
|
(define/override (after-insert start len)
|
|
(when styles-fixed?
|
|
(change-style (send (get-style-list) find-named-style "Standard")
|
|
start
|
|
(+ start len)
|
|
#f))
|
|
(super-after-insert start len)
|
|
(end-edit-sequence))
|
|
|
|
(public move/copy-to-edit)
|
|
(define (move/copy-to-edit 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)
|
|
(define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
|
|
|
|
(super-instantiate ())
|
|
(set-autowrap-bitmap (initial-autowrap-bitmap))))
|
|
|
|
(define hide-caret/selection<%> (interface (basic<%>)))
|
|
(define hide-caret/selection-mixin
|
|
(mixin (basic<%>) (hide-caret/selection<%>)
|
|
(override after-set-position)
|
|
(inherit get-start-position get-end-position hide-caret)
|
|
(define (after-set-position)
|
|
(hide-caret (= (get-start-position) (get-end-position))))
|
|
(super-instantiate ())))
|
|
|
|
(define nbsp->space<%> (interface ((class->interface text%))))
|
|
(define nbsp->space-mixin
|
|
(mixin ((class->interface text%)) (nbsp->space<%>)
|
|
(field [rewriting #f])
|
|
(inherit begin-edit-sequence end-edit-sequence delete insert get-character)
|
|
(rename [super-on-insert on-insert]
|
|
[super-after-insert after-insert])
|
|
(define/override (on-insert start len)
|
|
(begin-edit-sequence)
|
|
(super-on-insert start len))
|
|
(inherit find-string)
|
|
(define/override (after-insert start len)
|
|
(unless rewriting
|
|
(set! rewriting #t)
|
|
(let ([str (string (integer->char 160))]
|
|
[last-pos (+ start len)])
|
|
(let loop ([pos start])
|
|
(when (< pos last-pos)
|
|
(let ([next-pos (find-string str 'forward pos last-pos)])
|
|
(when next-pos
|
|
(delete next-pos (+ next-pos 1) #f)
|
|
(insert " " next-pos next-pos #f)
|
|
(loop (+ next-pos 1)))))))
|
|
(set! rewriting #f))
|
|
(super-after-insert start len)
|
|
(end-edit-sequence))
|
|
(super-instantiate ())))
|
|
|
|
(define searching<%> (interface (editor:keymap<%> basic<%>)))
|
|
(define searching-mixin
|
|
(mixin (editor:keymap<%> basic<%>) (searching<%>)
|
|
(rename [super-get-keymaps get-keymaps])
|
|
(override get-keymaps)
|
|
(define (get-keymaps)
|
|
(cons (keymap:get-search) (super-get-keymaps)))
|
|
(super-instantiate ())))
|
|
|
|
(define return<%> (interface ((class->interface text%))))
|
|
(define return-mixin
|
|
(mixin ((class->interface text%)) (return<%>)
|
|
(init-field return)
|
|
(rename [super-on-local-char on-local-char])
|
|
(override on-local-char)
|
|
(define (on-local-char 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))))
|
|
(super-instantiate ())))
|
|
|
|
(define delegate<%> (interface (basic<%>)
|
|
get-delegate
|
|
set-delegate))
|
|
|
|
(define small-version-of-snip%
|
|
(class snip%
|
|
(init-field big-snip)
|
|
(define width 0)
|
|
(define height 0)
|
|
(define/override (get-extent dc x y wb hb db sb lb rb)
|
|
(set/f! db 0)
|
|
(set/f! sb 0)
|
|
(set/f! lb 0)
|
|
(set/f! rb 0)
|
|
(let ([bwb (box 0)]
|
|
[bhb (box 0)])
|
|
(send big-snip get-extent dc x y bwb bhb #f #f #f #f)
|
|
(let* ([cw (send dc get-char-width)]
|
|
[ch (send dc get-char-height)]
|
|
[w (floor (/ (unbox bwb) cw))]
|
|
[h (floor (/ (unbox bhb) ch))])
|
|
(set/f! wb w)
|
|
(set/f! hb h)
|
|
(set! width w)
|
|
(set! height h))))
|
|
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(send dc draw-rectangle x y width height))
|
|
(define/override (copy) (instantiate small-version-of-snip% () (big-snip big-snip)))
|
|
(super-instantiate ())))
|
|
|
|
(define 1-pixel-string-snip%
|
|
(class string-snip%
|
|
(init-rest args)
|
|
(inherit get-text get-count set-count get-flags)
|
|
(define/override (split position first second)
|
|
(let* ([str (get-text 0 (get-count))]
|
|
[new-second (make-object 1-pixel-string-snip%
|
|
(substring str position (string-length str)))])
|
|
(set-box! first this)
|
|
(set-box! second new-second)
|
|
(set-count position)
|
|
(void)))
|
|
(define/override (copy)
|
|
(let ([cpy (make-object 1-pixel-string-snip%
|
|
(get-text 0 (get-count)))])
|
|
(send cpy set-flags (get-flags))))
|
|
(define/override (get-extent dc x y wb hb db sb lb rb)
|
|
(cond
|
|
[(memq 'invisible (get-flags))
|
|
(set/f! wb 0)]
|
|
[else
|
|
(set/f! wb (get-count))])
|
|
(set/f! hb 1)
|
|
(set/f! db 0)
|
|
(set/f! sb 0)
|
|
(set/f! lb 0)
|
|
(set/f! rb 0))
|
|
|
|
(define cache-function #f)
|
|
|
|
(rename [super-insert insert])
|
|
(define/override (insert s len pos)
|
|
(set! cache-function #f)
|
|
(super-insert s len pos))
|
|
|
|
;; for-each/sections : string -> dc number number -> void
|
|
(define (for-each/sections str)
|
|
(let loop ([n (string-length str)]
|
|
[len 0]
|
|
[blank? #t])
|
|
(cond
|
|
[(zero? n)
|
|
(if blank?
|
|
(lambda (dc x y) (void))
|
|
(lambda (dc x y)
|
|
(send dc draw-line (+ x n) y (+ x n (- len 1)) y)))]
|
|
[else
|
|
(let ([white? (char-whitespace? (string-ref str (- n 1)))])
|
|
(cond
|
|
[(eq? white? blank?)
|
|
(loop (- n 1) (+ len 1) blank?)]
|
|
[else
|
|
(let ([res (loop (- n 1) 1 (not blank?))])
|
|
(if blank?
|
|
res
|
|
(lambda (dc x y)
|
|
(send dc draw-line (+ x n) y (+ x n (- len 1)) y)
|
|
(res dc x y))))]))])))
|
|
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(let ([str (get-text 0 (get-count))])
|
|
(unless cache-function
|
|
(set! cache-function (for-each/sections str)))
|
|
(when (<= top y bottom)
|
|
(cache-function dc x y))))
|
|
(apply super-make-object args)))
|
|
|
|
(define 1-pixel-tab-snip%
|
|
(class tab-snip%
|
|
(init-rest args)
|
|
(inherit get-text get-count set-count get-flags)
|
|
(define/override (split position first second)
|
|
(let* ([str (get-text 0 (get-count))]
|
|
[new-second (make-object 1-pixel-string-snip%
|
|
(substring str position (string-length str)))])
|
|
(set-box! first this)
|
|
(set-box! second new-second)
|
|
(set-count position)
|
|
(void)))
|
|
(define/override (copy)
|
|
(let ([cpy (make-object 1-pixel-tab-snip%)])
|
|
(send cpy set-flags (get-flags))))
|
|
|
|
(inherit get-admin)
|
|
(define/override (get-extent dc x y wb hb db sb lb rb)
|
|
(set/f! wb 0)
|
|
(let ([admin (get-admin)])
|
|
(when admin
|
|
(let ([ed (send admin get-editor)])
|
|
(when (is-a? ed text%)
|
|
(let ([len-b (box 0)]
|
|
[tab-width-b (box 0)]
|
|
[in-units-b (box #f)])
|
|
(send ed get-tabs len-b tab-width-b in-units-b)
|
|
(when (and (or (equal? (unbox len-b) 0)
|
|
(equal? (unbox len-b) null))
|
|
(not (unbox in-units-b)))
|
|
(let ([tabspace (unbox tab-width-b)])
|
|
(set/f! wb (tabspace . - . (x . modulo . tabspace))))))))))
|
|
|
|
(set/f! hb 0)
|
|
(set/f! db 0)
|
|
(set/f! sb 0)
|
|
(set/f! lb 0)
|
|
(set/f! rb 0))
|
|
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(void))
|
|
(apply super-make-object args)))
|
|
|
|
(define (set/f! b n)
|
|
(when (box? b)
|
|
(set-box! b n)))
|
|
|
|
(define delegate-mixin
|
|
(mixin (basic<%>) (delegate<%>)
|
|
(inherit split-snip find-snip get-snip-position
|
|
find-first-snip get-style-list set-tabs)
|
|
|
|
(define linked-snips #f)
|
|
|
|
(define/private (copy snip)
|
|
(let ([new-snip
|
|
(cond
|
|
[(is-a? snip tab-snip%)
|
|
(let ([new-snip (make-object 1-pixel-tab-snip%)])
|
|
(send new-snip insert (string #\tab) 1)
|
|
new-snip)]
|
|
[(is-a? snip string-snip%)
|
|
(make-object 1-pixel-string-snip%
|
|
(send snip get-text 0 (send snip get-count)))]
|
|
[else
|
|
(let ([new-snip
|
|
(instantiate small-version-of-snip% ()
|
|
(big-snip snip))])
|
|
(hash-table-put! linked-snips snip new-snip)
|
|
new-snip)])])
|
|
(send new-snip set-flags (send snip get-flags))
|
|
new-snip))
|
|
|
|
(define delegate #f)
|
|
(inherit get-highlighted-ranges)
|
|
(define/public (get-delegate) delegate)
|
|
(define/public (set-delegate _d)
|
|
(set! delegate _d)
|
|
(set! linked-snips (if _d
|
|
(make-hash-table)
|
|
#f))
|
|
(when delegate
|
|
(refresh-delegate)))
|
|
|
|
(define/private (refresh-delegate)
|
|
(send delegate begin-edit-sequence)
|
|
(send delegate lock #f)
|
|
(when (is-a? this scheme:text<%>)
|
|
(send delegate set-tabs null (send this get-tab-size) #f))
|
|
(send delegate hide-caret #t)
|
|
(send delegate erase)
|
|
(send delegate set-style-list (get-style-list))
|
|
(let loop ([snip (find-first-snip)])
|
|
(when snip
|
|
(let ([copy-of-snip (copy snip)])
|
|
(send delegate insert
|
|
copy-of-snip
|
|
(send delegate last-position)
|
|
(send delegate last-position))
|
|
(loop (send snip next)))))
|
|
(for-each
|
|
(lambda (range)
|
|
(send delegate highlight-range
|
|
(range-start range)
|
|
(range-end range)
|
|
(range-color range)
|
|
(range-b/w-bitmap range)
|
|
(range-caret-space? range)
|
|
'high))
|
|
(reverse (get-highlighted-ranges)))
|
|
(send delegate lock #t)
|
|
(send delegate end-edit-sequence))
|
|
|
|
(rename [super-highlight-range highlight-range])
|
|
(define/override highlight-range
|
|
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
|
|
(let ([res (super-highlight-range start end color bitmap caret-space? priority)])
|
|
(if delegate
|
|
(let ([delegate-res (send delegate highlight-range
|
|
start end color bitmap caret-space? priority)])
|
|
(lambda ()
|
|
(res)
|
|
(delegate-res)))
|
|
res))))
|
|
|
|
(rename [super-on-paint on-paint])
|
|
(inherit get-canvases get-active-canvas has-focus?)
|
|
(define/override (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?
|
|
(let ([active-canvas (get-active-canvas)])
|
|
(when active-canvas
|
|
(send (send active-canvas get-top-level-window) delegate-moved)))))
|
|
|
|
(rename [super-on-edit-sequence on-edit-sequence])
|
|
(define/override (on-edit-sequence)
|
|
(super-on-edit-sequence)
|
|
(when delegate
|
|
(send delegate begin-edit-sequence)))
|
|
|
|
(rename [super-after-edit-sequence after-edit-sequence])
|
|
(define/override (after-edit-sequence)
|
|
(super-after-edit-sequence)
|
|
(when delegate
|
|
(send delegate end-edit-sequence)))
|
|
|
|
(rename [super-resized resized])
|
|
(define/override (resized snip redraw-now?)
|
|
(super-resized snip redraw-now?)
|
|
(when (and delegate
|
|
linked-snips
|
|
(not (is-a? snip string-snip%)))
|
|
(let ([delegate-copy (hash-table-get linked-snips snip (lambda () #f))])
|
|
(when delegate-copy
|
|
(send delegate resized delegate-copy redraw-now?)))))
|
|
|
|
(rename [super-after-insert after-insert])
|
|
(define/override (after-insert start len)
|
|
(super-after-insert start len)
|
|
(when delegate
|
|
(send delegate begin-edit-sequence)
|
|
(send delegate lock #f)
|
|
(split-snip start)
|
|
(split-snip (+ start len))
|
|
(let loop ([snip (find-snip (+ start len) 'before)])
|
|
(when snip
|
|
(unless ((get-snip-position snip) . < . start)
|
|
(send delegate insert (copy snip) start start)
|
|
(loop (send snip previous)))))
|
|
(send delegate lock #t)
|
|
(send delegate end-edit-sequence)))
|
|
|
|
(rename [super-after-delete after-delete])
|
|
(define/override (after-delete start len)
|
|
(super-after-delete start len)
|
|
(when delegate
|
|
(send delegate lock #f)
|
|
(send delegate begin-edit-sequence)
|
|
(send delegate delete start (+ start len))
|
|
(send delegate end-edit-sequence)
|
|
(send delegate lock #t)))
|
|
|
|
(rename [super-after-change-style after-change-style])
|
|
(define/override (after-change-style start len)
|
|
(super-after-change-style start len)
|
|
(when delegate
|
|
(send delegate begin-edit-sequence)
|
|
(send delegate lock #f)
|
|
(split-snip start)
|
|
(let* ([snip (find-snip start 'after)]
|
|
[style (send snip get-style)]
|
|
[other-style
|
|
'(send (send delegate get-style-list) find-or-create-style
|
|
style delegate-style-delta)])
|
|
(send delegate change-style style start (+ start len)))
|
|
(send delegate lock #f)
|
|
(send delegate end-edit-sequence)))
|
|
|
|
(define filename #f)
|
|
(define format #f)
|
|
(rename [super-on-load-file on-load-file]
|
|
[super-after-load-file after-load-file])
|
|
(define/override (on-load-file _filename _format)
|
|
(super-on-load-file _filename _format)
|
|
(set! filename _filename)
|
|
(set! format _format))
|
|
(define/override (after-load-file success?)
|
|
(super-after-load-file success?)
|
|
(when (and delegate success?)
|
|
(refresh-delegate)))
|
|
(super-instantiate ())))
|
|
|
|
(define info<%> (interface (basic<%>)))
|
|
|
|
(define info-mixin
|
|
(mixin (editor:keymap<%> basic<%>) (info<%>)
|
|
(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])
|
|
(define (enqueue-for-frame call-method tag)
|
|
(run-after-edit-sequence
|
|
(rec from-enqueue-for-frame
|
|
(lambda ()
|
|
(call-with-frame call-method)))
|
|
tag))
|
|
|
|
;; call-with-frame : ((is-a?/c frame:text-info<%>) -> void) -> void
|
|
;; calls the argument thunk with the frame showing this editor.
|
|
(define (call-with-frame call-method)
|
|
(let ([canvas (get-canvas)])
|
|
(when canvas
|
|
(let ([frame (send canvas get-top-level-window)])
|
|
(when (is-a? frame frame:text-info<%>)
|
|
(call-method frame))))))
|
|
|
|
(override set-anchor set-overwrite-mode after-set-position after-insert after-delete)
|
|
(define (set-anchor x)
|
|
(super-set-anchor x)
|
|
(enqueue-for-frame
|
|
(lambda (x) (send x anchor-status-changed))
|
|
'framework:anchor-status-changed))
|
|
(define (set-overwrite-mode x)
|
|
(super-set-overwrite-mode x)
|
|
(enqueue-for-frame
|
|
(lambda (x) (send x overwrite-status-changed))
|
|
'framework:overwrite-status-changed))
|
|
(define (after-set-position)
|
|
(super-after-set-position)
|
|
(maybe-queue-editor-position-update))
|
|
|
|
;; maybe-queue-editor-position-update : -> void
|
|
;; updates the editor-position in the frame,
|
|
;; but delays it until the next low-priority event occurs.
|
|
(define callback-running? #f)
|
|
(define/private (maybe-queue-editor-position-update)
|
|
(enqueue-for-frame
|
|
(lambda (frame)
|
|
(unless callback-running?
|
|
(set! callback-running? #t)
|
|
(queue-callback
|
|
(lambda ()
|
|
(send frame editor-position-changed)
|
|
(set! callback-running? #f))
|
|
#f)))
|
|
'framework:info-frame:update-editor-position))
|
|
|
|
(define (after-insert start len)
|
|
(super-after-insert start len)
|
|
(maybe-queue-editor-position-update))
|
|
(define (after-delete start len)
|
|
(super-after-delete start len)
|
|
(maybe-queue-editor-position-update))
|
|
(super-instantiate ())))
|
|
|
|
(define clever-file-format<%> (interface ((class->interface text%))))
|
|
|
|
(define clever-file-format-mixin
|
|
(mixin ((class->interface text%)) (clever-file-format<%>)
|
|
(inherit get-file-format set-file-format find-first-snip)
|
|
(rename [super-on-save-file on-save-file])
|
|
(define (all-string-snips)
|
|
(let loop ([s (find-first-snip)])
|
|
(cond
|
|
[(not s) #t]
|
|
[(is-a? s string-snip%)
|
|
(loop (send s next))]
|
|
[else #f])))
|
|
(define/override (on-save-file name format)
|
|
(let ([all-strings? (all-string-snips)])
|
|
(cond
|
|
[(and all-strings?
|
|
(eq? format 'same)
|
|
(eq? 'standard (get-file-format))
|
|
(or (not (preferences:get 'framework:verify-change-format))
|
|
(gui-utils:get-choice
|
|
(string-constant save-as-plain-text)
|
|
(string-constant yes)
|
|
(string-constant no))))
|
|
(set-file-format 'text)]
|
|
[(and (not all-strings?)
|
|
(eq? format 'same)
|
|
(eq? 'text (get-file-format))
|
|
(or (not (preferences:get 'framework:verify-change-format))
|
|
(gui-utils:get-choice
|
|
(string-constant save-in-drs-format)
|
|
(string-constant yes)
|
|
(string-constant no))))
|
|
(set-file-format 'standard)]
|
|
[else (void)]))
|
|
(super-on-save-file name format))
|
|
(super-instantiate ())))
|
|
|
|
(define basic% (basic-mixin (editor:basic-mixin text%)))
|
|
(define hide-caret/selection% (hide-caret/selection-mixin basic%))
|
|
(define nbsp->space% (nbsp->space-mixin basic%))
|
|
(define delegate% (delegate-mixin basic%))
|
|
(define standard-style-list% (editor:standard-style-list-mixin basic%))
|
|
(define -keymap% (editor:keymap-mixin standard-style-list%))
|
|
(define return% (return-mixin -keymap%))
|
|
(define autowrap% (editor:autowrap-mixin -keymap%))
|
|
(define file% (editor:file-mixin autowrap%))
|
|
(define clever-file-format% (clever-file-format-mixin file%))
|
|
(define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
|
|
(define searching% (searching-mixin backup-autosave%))
|
|
(define info% (info-mixin (editor:info-mixin searching%))))))
|