2060 lines
90 KiB
Scheme
2060 lines
90 KiB
Scheme
#|
|
|
|
|
WARNING: printf is rebound in the body of the unit to always
|
|
print to the original output port.
|
|
|
|
|#
|
|
|
|
(module text (lib "a-unit.ss")
|
|
(require (lib "string-constant.ss" "string-constants")
|
|
(lib "class.ss")
|
|
(lib "match.ss")
|
|
"sig.ss"
|
|
"../gui-utils.ss"
|
|
"../preferences.ss"
|
|
(lib "mred-sig.ss" "mred")
|
|
(lib "interactive-value-port.ss" "mrlib")
|
|
(lib "list.ss")
|
|
(lib "etc.ss"))
|
|
|
|
(import mred^
|
|
[prefix icon: framework:icon^]
|
|
[prefix editor: framework:editor^]
|
|
[prefix keymap: framework:keymap^]
|
|
[prefix color-model: framework:color-model^]
|
|
[prefix frame: framework:frame^]
|
|
[prefix scheme: framework:scheme^]
|
|
[prefix number-snip: framework:number-snip^]
|
|
[prefix finder: framework:finder^])
|
|
(export (rename framework:text^
|
|
[-keymap% keymap%]))
|
|
(init-depend framework:editor^)
|
|
|
|
(define original-output-port (current-output-port))
|
|
(define (printf . args)
|
|
(apply fprintf original-output-port args)
|
|
(void))
|
|
|
|
(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
|
|
unhighlight-range
|
|
get-highlighted-ranges
|
|
get-styles-fixed
|
|
get-fixed-style
|
|
set-styles-fixed
|
|
move/copy-to-edit
|
|
initial-autowrap-bitmap))
|
|
|
|
(define basic-mixin
|
|
(mixin (editor:basic<%> (class->interface text%)) (basic<%>)
|
|
(inherit get-canvas 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-final (get-highlighted-ranges) ranges)
|
|
(define/public (get-fixed-style)
|
|
(send (get-style-list) find-named-style "Standard"))
|
|
|
|
(define/private (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
|
|
(λ ()
|
|
(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/private (recompute-range-rectangles)
|
|
(let* ([b1 (box 0)]
|
|
[b2 (box 0)]
|
|
[new-rectangles
|
|
(λ (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 (λ (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?
|
|
(λ (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)
|
|
(λ () (unhighlight-range start end color bitmap caret-space?)))))
|
|
|
|
(define/public unhighlight-range
|
|
(opt-lambda (start end color [bitmap #f] [caret-space? #f])
|
|
(let ([old-rectangles range-rectangles])
|
|
(set! ranges
|
|
(let loop ([r ranges])
|
|
(cond
|
|
[(null? r) r]
|
|
[else (if (matching-rectangle? (car r) start end color bitmap caret-space?)
|
|
(cdr r)
|
|
(cons (car r) (loop (cdr r))))])))
|
|
(recompute-range-rectangles)
|
|
(invalidate-rectangles old-rectangles))))
|
|
|
|
(define/private (matching-rectangle? r start end color bitmap caret-space?)
|
|
(and (equal? start (range-start r))
|
|
(equal? end (range-end r))
|
|
(eq? bitmap (range-b/w-bitmap r))
|
|
(equal? color (range-color r))
|
|
(equal? caret-space? (range-caret-space? r))))
|
|
|
|
(define/override (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
|
|
(λ (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 (λ (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))
|
|
|
|
(define/augment (on-insert start len)
|
|
(begin-edit-sequence)
|
|
(inner (void) on-insert start len))
|
|
(define/augment (after-insert start len)
|
|
(when styles-fixed?
|
|
(change-style (get-fixed-style) start (+ start len) #f))
|
|
(inner (void) 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))
|
|
|
|
(define/override (put-file directory default-name)
|
|
(let* ([canvas (get-canvas)]
|
|
[parent (and canvas (send canvas get-top-level-window))])
|
|
(finder:put-file default-name
|
|
directory
|
|
#f
|
|
(string-constant select-file)
|
|
#f
|
|
""
|
|
parent)))
|
|
|
|
(super-new)
|
|
(set-autowrap-bitmap (initial-autowrap-bitmap))))
|
|
|
|
(define foreground-color<%>
|
|
(interface (basic<%> editor:standard-style-list<%>)
|
|
))
|
|
|
|
(define foreground-color-mixin
|
|
(mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>)
|
|
(inherit begin-edit-sequence end-edit-sequence change-style get-style-list)
|
|
|
|
(define/override (default-style-name)
|
|
(editor:get-default-color-style-name))
|
|
|
|
(define/override (get-fixed-style)
|
|
(send (editor:get-standard-style-list)
|
|
find-named-style
|
|
(editor:get-default-color-style-name)))
|
|
(super-new)))
|
|
|
|
(define hide-caret/selection<%> (interface (basic<%>)))
|
|
(define hide-caret/selection-mixin
|
|
(mixin (basic<%>) (hide-caret/selection<%>)
|
|
(inherit get-start-position get-end-position hide-caret)
|
|
(define/augment (after-set-position)
|
|
(hide-caret (= (get-start-position) (get-end-position)))
|
|
(inner (void) after-set-position))
|
|
(super-new)))
|
|
|
|
(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)
|
|
(define/augment (on-insert start len)
|
|
(inner (void) on-insert start len)
|
|
(begin-edit-sequence))
|
|
(inherit find-string)
|
|
(define/augment (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))
|
|
(end-edit-sequence)
|
|
(inner (void) after-insert start len))
|
|
(super-instantiate ())))
|
|
|
|
(define searching<%> (interface (editor:keymap<%> basic<%>)))
|
|
(define searching-mixin
|
|
(mixin (editor:keymap<%> basic<%>) (searching<%>)
|
|
(define/override (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)
|
|
(define/override (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-new)))
|
|
|
|
(define wide-snip<%>
|
|
(interface (basic<%>)
|
|
add-wide-snip
|
|
add-tall-snip))
|
|
|
|
(define wide-snip-mixin
|
|
(mixin (basic<%>) (wide-snip<%>)
|
|
(define wide-snips '())
|
|
(define tall-snips '())
|
|
(define/public (add-wide-snip s) (set! wide-snips (cons s wide-snips)))
|
|
(define/public (get-wide-snips) wide-snips)
|
|
(define/public (add-tall-snip s) (set! tall-snips (cons s tall-snips)))
|
|
(define/public (get-tall-snips) tall-snips)
|
|
(super-new)))
|
|
|
|
(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)
|
|
|
|
(define/override (insert s len pos)
|
|
(set! cache-function #f)
|
|
(super insert s len pos))
|
|
|
|
;; for-each/sections : string -> dc number number -> void
|
|
(define/private (for-each/sections str)
|
|
(let loop ([n (string-length str)]
|
|
[len 0]
|
|
[blank? #t])
|
|
(cond
|
|
[(zero? n)
|
|
(if blank?
|
|
(λ (dc x y) (void))
|
|
(λ (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
|
|
(λ (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))
|
|
(send new-snip set-style (send snip get-style))
|
|
new-snip))
|
|
|
|
(define delegate #f)
|
|
(inherit get-highlighted-ranges)
|
|
(define/public-final (get-delegate) delegate)
|
|
(define/public-final (set-delegate _d)
|
|
(set! delegate _d)
|
|
(set! linked-snips (if _d
|
|
(make-hash-table)
|
|
#f))
|
|
(refresh-delegate))
|
|
|
|
(define/private (refresh-delegate)
|
|
(when 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
|
|
(λ (range)
|
|
(send delegate unhighlight-range
|
|
(range-start range)
|
|
(range-end range)
|
|
(range-color range)
|
|
(range-b/w-bitmap range)
|
|
(range-caret-space? range)))
|
|
(send delegate get-highlighted-ranges))
|
|
(for-each
|
|
(λ (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)))
|
|
|
|
(define/override highlight-range
|
|
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
|
|
(when delegate
|
|
(send delegate highlight-range
|
|
start end color bitmap caret-space? priority))
|
|
(super highlight-range start end color bitmap caret-space? priority)))
|
|
|
|
(define/override unhighlight-range
|
|
(opt-lambda (start end color [bitmap #f] [caret-space? #f])
|
|
(when delegate
|
|
(send delegate unhighlight-range start end color bitmap caret-space?))
|
|
(super unhighlight-range start end color bitmap caret-space?)))
|
|
|
|
(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)))))
|
|
|
|
(define/augment (on-edit-sequence)
|
|
(when delegate
|
|
(send delegate begin-edit-sequence))
|
|
(inner (void) on-edit-sequence))
|
|
|
|
(define/augment (after-edit-sequence)
|
|
(when delegate
|
|
(send delegate end-edit-sequence))
|
|
(inner (void) after-edit-sequence))
|
|
|
|
(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 (λ () #f))])
|
|
(when delegate-copy
|
|
(send delegate resized delegate-copy redraw-now?)))))
|
|
|
|
(define/augment (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))
|
|
(inner (void) after-insert start len))
|
|
|
|
(define/augment (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))
|
|
(inner (void) after-delete start len))
|
|
|
|
(define/augment (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))
|
|
(inner (void) after-change-style start len))
|
|
|
|
(define filename #f)
|
|
(define format #f)
|
|
(define/augment (on-load-file _filename _format)
|
|
(set! filename _filename)
|
|
(set! format _format)
|
|
(inner (void) on-load-file _filename _format))
|
|
(define/augment (after-load-file success?)
|
|
(when success?
|
|
(refresh-delegate))
|
|
(inner (void) after-load-file success?))
|
|
(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)
|
|
(define/private (enqueue-for-frame call-method tag)
|
|
(run-after-edit-sequence
|
|
(rec from-enqueue-for-frame
|
|
(λ ()
|
|
(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/private (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))))))
|
|
|
|
(define/override (set-anchor x)
|
|
(super set-anchor x)
|
|
(enqueue-for-frame
|
|
(λ (x) (send x anchor-status-changed))
|
|
'framework:anchor-status-changed))
|
|
(define/override (set-overwrite-mode x)
|
|
(super set-overwrite-mode x)
|
|
(enqueue-for-frame
|
|
(λ (x) (send x overwrite-status-changed))
|
|
'framework:overwrite-status-changed))
|
|
(define/augment (after-set-position)
|
|
(maybe-queue-editor-position-update)
|
|
(inner (void) after-set-position))
|
|
|
|
;; 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
|
|
(λ (frame)
|
|
(unless callback-running?
|
|
(set! callback-running? #t)
|
|
(queue-callback
|
|
(λ ()
|
|
(send frame editor-position-changed)
|
|
(set! callback-running? #f))
|
|
#f)))
|
|
'framework:info-frame:update-editor-position))
|
|
|
|
(define/augment (after-insert start len)
|
|
(maybe-queue-editor-position-update)
|
|
(inner (void) after-insert start len))
|
|
(define/augment (after-delete start len)
|
|
(maybe-queue-editor-position-update)
|
|
(inner (void) after-delete start len))
|
|
(super-new)))
|
|
|
|
(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)
|
|
(define/private (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/augment (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)]))
|
|
(inner (void) on-save-file name format))
|
|
(super-instantiate ())))
|
|
|
|
|
|
(define file<%>
|
|
(interface (editor:file<%> basic<%>)
|
|
get-read-write?))
|
|
|
|
(define file-mixin
|
|
(mixin (editor:file<%> basic<%>) (file<%>)
|
|
(inherit get-filename)
|
|
(define read-write? #t)
|
|
(define/public (get-read-write?) read-write?)
|
|
(define/private (check-lock)
|
|
(let* ([filename (get-filename)]
|
|
[can-edit? (if (and filename
|
|
(file-exists? filename))
|
|
(and (member 'write (file-or-directory-permissions filename))
|
|
#t)
|
|
#t)])
|
|
(set! read-write? can-edit?)))
|
|
|
|
(define/augment (can-insert? x y)
|
|
(and read-write? (inner #t can-insert? x y)))
|
|
(define/augment (can-delete? x y)
|
|
(and read-write? (inner #t can-delete? x y)))
|
|
|
|
(define/augment (after-save-file success)
|
|
(when success
|
|
(check-lock))
|
|
(inner (void) after-save-file success))
|
|
|
|
(define/augment (after-load-file sucessful?)
|
|
(when sucessful?
|
|
(check-lock))
|
|
(inner (void) after-load-file sucessful?))
|
|
(super-new)))
|
|
|
|
|
|
(define ports<%>
|
|
(interface ()
|
|
delete/io
|
|
get-insertion-point
|
|
set-insertion-point
|
|
get-unread-start-point
|
|
set-unread-start-point
|
|
set-allow-edits
|
|
get-allow-edits
|
|
insert-between
|
|
insert-before
|
|
submit-to-port?
|
|
on-submit
|
|
send-eof-to-in-port
|
|
send-eof-to-box-in-port
|
|
reset-input-box
|
|
clear-output-ports
|
|
clear-input-port
|
|
clear-box-input-port
|
|
get-out-style-delta
|
|
get-err-style-delta
|
|
get-value-style-delta
|
|
get-in-port
|
|
get-in-box-port
|
|
get-out-port
|
|
get-err-port
|
|
get-value-port
|
|
after-io-insertion
|
|
get-box-input-editor-snip%
|
|
get-box-input-text%))
|
|
|
|
(define-struct peeker (bytes skip-count pe resp-chan nack polling?) (make-inspector))
|
|
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
|
|
|
|
(define msec-timeout 500)
|
|
(define output-buffer-full 4096)
|
|
|
|
(define-local-member-name
|
|
new-box-input
|
|
box-input-not-used-anymore
|
|
set-port-text)
|
|
|
|
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
|
|
|
(define arrow-cursor (make-object cursor% 'arrow))
|
|
|
|
(define eof-snip%
|
|
(class image-snip%
|
|
(init-field port-text)
|
|
(define/override (get-extent dc x y w h descent space lspace rspace)
|
|
(super get-extent dc x y w h descent space lspace rspace)
|
|
(set-box/f! descent 7)) ;; depends on actual bitmap used ...
|
|
|
|
(define/override (on-event dc x y editorx editory event)
|
|
(when (send event button-up? 'left)
|
|
(send port-text send-eof-to-box-in-port)))
|
|
(define/override (adjust-cursor dc x y edx edy e)
|
|
arrow-cursor)
|
|
(super-make-object (icon:get-eof-bitmap))
|
|
(inherit set-flags get-flags)
|
|
(set-flags (list* 'handles-events (get-flags)))))
|
|
|
|
(define out-style-name "text:ports out")
|
|
(define error-style-name "text:ports err")
|
|
(define value-style-name "text:ports value")
|
|
(let ([create-style-name
|
|
(λ (name sd)
|
|
(let* ([sl (editor:get-standard-style-list)])
|
|
(send sl new-named-style
|
|
name
|
|
(send sl find-or-create-style
|
|
(send sl find-named-style "Standard")
|
|
sd))))])
|
|
(let ([out-sd (make-object style-delta% 'change-nothing)])
|
|
(send out-sd set-delta-foreground (make-object color% 150 0 150))
|
|
(create-style-name out-style-name out-sd))
|
|
(let ([err-sd (make-object style-delta% 'change-italic)])
|
|
(send err-sd set-delta-foreground (make-object color% 255 0 0))
|
|
(create-style-name error-style-name err-sd))
|
|
(let ([value-sd (make-object style-delta% 'change-nothing)])
|
|
(send value-sd set-delta-foreground (make-object color% 0 0 175))
|
|
(create-style-name value-style-name value-sd)))
|
|
|
|
(define ports-mixin
|
|
(mixin (wide-snip<%>) (ports<%>)
|
|
(inherit begin-edit-sequence
|
|
change-style
|
|
delete
|
|
end-edit-sequence
|
|
find-snip
|
|
insert
|
|
get-canvas
|
|
get-start-position
|
|
get-end-position
|
|
get-snip-position
|
|
get-style-list
|
|
is-locked?
|
|
last-position
|
|
lock
|
|
paragraph-start-position
|
|
position-paragraph
|
|
release-snip
|
|
set-caret-owner
|
|
split-snip
|
|
get-focus-snip
|
|
get-view-size
|
|
scroll-to-position
|
|
position-location)
|
|
|
|
;; private field
|
|
(define eventspace (current-eventspace))
|
|
|
|
;; insertion-point : number
|
|
;; the place where the output ports insert data
|
|
;; only updated in `eventspace' (above)'s main thread
|
|
(define insertion-point 0)
|
|
|
|
;; unread-start-points : number
|
|
;; from this position to the end of the buffer is the
|
|
;; users editing that has not been committed to the
|
|
;; port.
|
|
;; only updated in `eventspace' (above)'s main thread
|
|
(define unread-start-point 0)
|
|
|
|
;; box-input : (union #f (is-a?/c editor-snip%))
|
|
;; the snip where the user's input is typed for the box input port
|
|
(define box-input #f)
|
|
(define eof-button (new eof-snip% (port-text this)))
|
|
|
|
;; allow-edits? : boolean
|
|
;; when this flag is set, only insert/delete after the
|
|
;; insertion-point are allowed.
|
|
(define allow-edits? #f)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; public interface
|
|
;;
|
|
|
|
;; insert-between : string/snp -> void
|
|
;; inserts something between the insertion point and the unread region
|
|
(define/public-final (insert-between str/snp)
|
|
(insert str/snp unread-start-point unread-start-point)
|
|
(set! unread-start-point (+ unread-start-point
|
|
(amt-of-space str/snp))))
|
|
|
|
;; insert-before : string/snp -> void
|
|
;; inserts something before both the insertion point and the unread region
|
|
(define/public-final (insert-before str/snp)
|
|
(insert str/snp insertion-point insertion-point)
|
|
(let ([amt (amt-of-space str/snp)])
|
|
(set! insertion-point (+ insertion-point amt))
|
|
(set! unread-start-point (+ unread-start-point amt))))
|
|
|
|
(define/private (amt-of-space str/snp)
|
|
(cond
|
|
[(string? str/snp) (string-length str/snp)]
|
|
[(is-a? str/snp snip%)
|
|
(send str/snp get-count)]))
|
|
|
|
(define/public-final (get-insertion-point) insertion-point)
|
|
(define/public-final (set-insertion-point ip) (set! insertion-point ip))
|
|
(define/public-final (get-unread-start-point)
|
|
unread-start-point)
|
|
(define/public-final (set-unread-start-point u)
|
|
(unless (<= u (last-position))
|
|
(error 'set-unread-start-point "~e is too large, last-position is ~e"
|
|
unread-start-point
|
|
(last-position)))
|
|
(set! unread-start-point u))
|
|
|
|
(define/public-final (set-allow-edits allow?) (set! allow-edits? allow?))
|
|
(define/public-final (get-allow-edits) allow-edits?)
|
|
|
|
(define/public-final (send-eof-to-in-port)
|
|
(channel-put read-chan (cons eof (position->line-col-pos unread-start-point))))
|
|
(define/public-final (send-eof-to-box-in-port)
|
|
(channel-put box-read-chan (cons eof (position->line-col-pos unread-start-point))))
|
|
(define/public-final (clear-input-port) (channel-put clear-input-chan (void)))
|
|
(define/public-final (clear-box-input-port) (channel-put box-clear-input-chan (void)))
|
|
(define/public-final (clear-output-ports)
|
|
(channel-put clear-output-chan (void))
|
|
(init-output-ports))
|
|
|
|
;; delete/io: number number -> void
|
|
(define/public-final (delete/io start end)
|
|
(unless (<= start end insertion-point)
|
|
(error 'delete/io "expected start (~a) <= end (~a) <= insertion-point (~a)"
|
|
start end insertion-point))
|
|
|
|
(let ([dist (- end start)])
|
|
(set! insertion-point (- insertion-point dist))
|
|
(set! unread-start-point (- unread-start-point dist)))
|
|
|
|
(let ([before-allowed? allow-edits?])
|
|
(set! allow-edits? #t)
|
|
(delete start end #f)
|
|
(set! allow-edits? before-allowed?)))
|
|
|
|
(define/public-final (get-in-port)
|
|
(unless in-port (error 'get-in-port "not ready"))
|
|
in-port)
|
|
(define/public-final (get-in-box-port)
|
|
(unless in-port (error 'get-in-box-port "not ready"))
|
|
in-box-port)
|
|
(define/public-final (get-out-port)
|
|
(unless out-port (error 'get-out-port "not ready"))
|
|
out-port)
|
|
(define/public-final (get-err-port)
|
|
(unless err-port (error 'get-err-port "not ready"))
|
|
err-port)
|
|
(define/public-final (get-value-port)
|
|
(unless value-port (error 'get-value-port "not ready"))
|
|
value-port)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; specialization interface
|
|
;;
|
|
|
|
(define/pubment (submit-to-port? key) (inner #t submit-to-port? key))
|
|
(define/pubment (on-submit) (inner (void) on-submit))
|
|
(define/public (get-out-style-delta) out-style-name)
|
|
(define/public (get-err-style-delta) error-style-name)
|
|
(define/public (get-value-style-delta) value-style-name)
|
|
|
|
(define/public (get-box-input-editor-snip%) editor-snip%)
|
|
(define/public (get-box-input-text%) input-box%)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; editor integration
|
|
;;
|
|
|
|
(define/augment (can-insert? start len)
|
|
(and (or allow-edits?
|
|
(start . >= . unread-start-point))
|
|
(inner #t can-insert? start len)))
|
|
|
|
(define/augment (can-delete? start len)
|
|
(and (or allow-edits?
|
|
(start . >= . unread-start-point))
|
|
(inner #t can-delete? start len)))
|
|
|
|
(define/override (on-local-char key)
|
|
(let ([start (get-start-position)]
|
|
[end (get-end-position)]
|
|
[code (send key get-key-code)])
|
|
(cond
|
|
[(not (or (eq? code 'numpad-enter)
|
|
(equal? code #\return)
|
|
(equal? code #\newline)))
|
|
(super on-local-char key)]
|
|
[(and (insertion-point . <= . start)
|
|
(= start end)
|
|
(submit-to-port? key))
|
|
(insert "\n")
|
|
(for-each/snips-chars
|
|
unread-start-point
|
|
(last-position)
|
|
(λ (s/c line-col-pos)
|
|
(cond
|
|
[(is-a? s/c snip%)
|
|
(channel-put read-chan (cons s/c line-col-pos))]
|
|
[(char? s/c)
|
|
(for-each (λ (b) (channel-put read-chan (cons b line-col-pos)))
|
|
(bytes->list (string->bytes/utf-8 (string s/c))))])))
|
|
(set! unread-start-point (last-position))
|
|
(set! insertion-point (last-position))
|
|
(on-submit)]
|
|
[else
|
|
(super on-local-char key)])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; box input port management
|
|
;;
|
|
|
|
(define/public-final (reset-input-box)
|
|
(when box-input
|
|
(let ([l? (is-locked?)]
|
|
[old-allow-edits? allow-edits?])
|
|
(lock #f)
|
|
(set! allow-edits? #t)
|
|
(send box-input release-from-owner)
|
|
(send eof-button release-from-owner)
|
|
(set! unread-start-point (- unread-start-point 2))
|
|
(set! allow-edits? old-allow-edits?)
|
|
(lock l?))
|
|
(set! box-input #f)))
|
|
|
|
(define/private (adjust-box-input-width)
|
|
(when box-input
|
|
(let ([w (box 0)]
|
|
[x (box 0)]
|
|
[bw (send (icon:get-eof-bitmap) get-width)])
|
|
(get-view-size w #f)
|
|
(let ([pos (- (last-position) 2)])
|
|
(position-location pos x #f #t
|
|
(not (= pos (paragraph-start-position (position-paragraph pos))))))
|
|
(let ([size (- (unbox w) (unbox x) bw 24)])
|
|
(when (positive? size)
|
|
(send box-input set-min-width size))))))
|
|
|
|
(define/augment (on-display-size)
|
|
(adjust-box-input-width)
|
|
(inner (void) on-display-size))
|
|
|
|
(define/private (on-box-peek)
|
|
(unless box-input
|
|
(let* ([ed (new (get-box-input-text%))]
|
|
[es (new (get-box-input-editor-snip%)
|
|
(editor ed))]
|
|
[locked? (is-locked?)])
|
|
(begin-edit-sequence)
|
|
(send ed set-port-text this)
|
|
(lock #f)
|
|
#;(unless (= unread-start-point (paragraph-start-position (position-paragraph unread-start-point)))
|
|
(insert-between "\n"))
|
|
(insert-between es)
|
|
(insert-between eof-button)
|
|
#;(send (get-canvas) add-wide-snip es)
|
|
(set! box-input es)
|
|
(adjust-box-input-width)
|
|
(set-caret-owner es 'display)
|
|
(lock locked?)
|
|
(end-edit-sequence))))
|
|
|
|
(define/public (new-box-input ed)
|
|
(when (eq? ed (send box-input get-editor)) ;; just in case things get out of sync.
|
|
(let ([locked? (is-locked?)])
|
|
(begin-edit-sequence)
|
|
(send box-input set-min-width 'none)
|
|
(lock #f)
|
|
|
|
(let ([old-insertion-point insertion-point])
|
|
(let loop ([snip (send (send box-input get-editor) find-first-snip)])
|
|
(when snip
|
|
(let ([next (send snip next)])
|
|
(send snip release-from-owner)
|
|
(do-insertion
|
|
(list (cons (cond
|
|
[(is-a? snip string-snip%)
|
|
(send snip get-text 0 (send snip get-count))]
|
|
[else snip])
|
|
(make-object style-delta%)))
|
|
#t)
|
|
(loop next))))
|
|
|
|
;; this is copied code ...
|
|
(for-each/snips-chars
|
|
old-insertion-point
|
|
insertion-point
|
|
(λ (s/c line-col-pos)
|
|
(cond
|
|
[(is-a? s/c snip%)
|
|
(channel-put box-read-chan (cons s/c line-col-pos))]
|
|
[(char? s/c)
|
|
(for-each (λ (b) (channel-put box-read-chan (cons b line-col-pos)))
|
|
(bytes->list (string->bytes/utf-8 (string s/c))))]))))
|
|
|
|
(lock locked?)
|
|
(adjust-box-input-width)
|
|
(end-edit-sequence))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; output port syncronization code
|
|
;;
|
|
|
|
;; flush-chan : (channel (evt void))
|
|
;; signals that the buffer-thread should flush pending output
|
|
;; the evt inside is waited on to indicate the flush has occurred
|
|
(define flush-chan (make-channel))
|
|
|
|
;; clear-output-chan : (channel void)
|
|
(define clear-output-chan (make-channel))
|
|
|
|
;; write-chan : (channel (cons (union snip bytes) style))
|
|
;; send output to the editor
|
|
(define write-chan (make-channel))
|
|
|
|
;; readers-chan : (channel (list (channel (union byte snip))
|
|
;; (channel ...)))
|
|
(define readers-chan (make-channel))
|
|
|
|
;; queue-insertion : (listof (cons (union string snip) style)) evt -> void
|
|
;; txt is in the reverse order of the things to be inserted.
|
|
;; the evt is waited on when the text has actually been inserted
|
|
;; thread: any thread, except the eventspace main thread
|
|
(define/private (queue-insertion txts signal)
|
|
(parameterize ([current-eventspace eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(do-insertion txts #f)
|
|
(sync signal)))))
|
|
|
|
;; do-insertion : (listof (cons (union string snip) style-delta)) boolean -> void
|
|
;; thread: eventspace main thread
|
|
(define/private (do-insertion txts showing-input?)
|
|
(let ([locked? (is-locked?)])
|
|
(begin-edit-sequence)
|
|
(lock #f)
|
|
(set! allow-edits? #t)
|
|
(let loop ([txts txts])
|
|
(cond
|
|
[(null? txts) (void)]
|
|
[else
|
|
(let* ([fst (car txts)]
|
|
[str/snp (car fst)]
|
|
[style (cdr fst)])
|
|
|
|
(let ([inserted-count
|
|
(if (is-a? str/snp snip%)
|
|
(send str/snp get-count)
|
|
(string-length str/snp))]
|
|
[old-insertion-point insertion-point])
|
|
(set! insertion-point (+ insertion-point inserted-count))
|
|
(set! unread-start-point (+ unread-start-point inserted-count))
|
|
|
|
(insert (if (is-a? str/snp snip%)
|
|
(send str/snp copy)
|
|
str/snp)
|
|
old-insertion-point
|
|
old-insertion-point
|
|
#t)
|
|
|
|
;; the idea here is that if you made a string snip, you
|
|
;; could have made a string and gotten the style, so you
|
|
;; must intend to have your own style.
|
|
(unless (is-a? str/snp string-snip%)
|
|
(change-style style old-insertion-point insertion-point))))
|
|
(loop (cdr txts))]))
|
|
(set! allow-edits? #f)
|
|
(lock locked?)
|
|
(unless showing-input?
|
|
(when box-input
|
|
(adjust-box-input-width)
|
|
(when (eq? box-input (get-focus-snip))
|
|
(scroll-to-position (last-position)))))
|
|
(end-edit-sequence)
|
|
(unless (null? txts)
|
|
(after-io-insertion))))
|
|
|
|
(define/public (after-io-insertion) (void))
|
|
|
|
(define output-buffer-thread
|
|
(let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
|
|
(thread
|
|
(λ ()
|
|
(let loop (;; text-to-insert : (queue (cons (union snip bytes) style))
|
|
[text-to-insert (empty-queue)]
|
|
[last-flush (current-inexact-milliseconds)])
|
|
|
|
(sync
|
|
(if (queue-empty? text-to-insert)
|
|
never-evt
|
|
(handle-evt
|
|
(alarm-evt (+ last-flush msec-timeout))
|
|
(λ (_)
|
|
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
|
|
(queue-insertion viable-bytes always-evt)
|
|
(loop remaining-queue (current-inexact-milliseconds))))))
|
|
(handle-evt
|
|
flush-chan
|
|
(λ (return-evt)
|
|
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
|
|
(queue-insertion viable-bytes return-evt)
|
|
(loop remaining-queue (current-inexact-milliseconds)))))
|
|
(handle-evt
|
|
clear-output-chan
|
|
(λ (_)
|
|
(loop (empty-queue) (current-inexact-milliseconds))))
|
|
(handle-evt
|
|
write-chan
|
|
(λ (pr)
|
|
(let ([new-text-to-insert (enqueue pr text-to-insert)])
|
|
(cond
|
|
[((queue-size text-to-insert) . < . output-buffer-full)
|
|
(loop new-text-to-insert last-flush)]
|
|
[else
|
|
(let ([chan (make-channel)])
|
|
(let-values ([(viable-bytes remaining-queue)
|
|
(split-queue converter new-text-to-insert)])
|
|
(queue-insertion viable-bytes (channel-put-evt chan (void)))
|
|
(channel-get chan)
|
|
(loop remaining-queue (current-inexact-milliseconds))))]))))))))))
|
|
|
|
(field [in-port-args #f]
|
|
[out-port #f]
|
|
[err-port #f]
|
|
[value-port #f])
|
|
|
|
(define/private (init-output-ports)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; the following must be able to run
|
|
;; in any thread (even concurrently)
|
|
;;
|
|
(define (make-write-bytes-proc style)
|
|
(λ (to-write start end block/buffer? enable-breaks?)
|
|
(cond
|
|
[(= start end) (flush-proc)]
|
|
[(eq? (current-thread) (eventspace-handler-thread eventspace))
|
|
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
|
|
[else
|
|
(channel-put write-chan (cons (subbytes to-write start end) style))])
|
|
(- end start)))
|
|
|
|
(define (flush-proc)
|
|
(cond
|
|
[(eq? (current-thread) (eventspace-handler-thread eventspace))
|
|
(error 'flush-proc "cannot flush port on eventspace main thread")]
|
|
[else
|
|
(sync
|
|
(nack-guard-evt
|
|
(λ (fail-channel)
|
|
(let* ([return-channel (make-channel)]
|
|
[return-evt
|
|
(choice-evt
|
|
fail-channel
|
|
(channel-put-evt return-channel (void)))])
|
|
(channel-put flush-chan return-evt)
|
|
return-channel))))]))
|
|
|
|
(define (out-close-proc)
|
|
(void))
|
|
|
|
(define (make-write-special-proc style)
|
|
(λ (special can-buffer? enable-breaks?)
|
|
(cond
|
|
[(eq? (current-thread) (eventspace-handler-thread eventspace))
|
|
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
|
|
[else
|
|
(let ([str/snp (cond
|
|
[(string? special) special]
|
|
[(is-a? special snip%) special]
|
|
[else (format "~s" special)])])
|
|
(channel-put
|
|
write-chan
|
|
(cons str/snp style)))])
|
|
#t))
|
|
|
|
(let* ([add-standard
|
|
(λ (sd)
|
|
(cond
|
|
[(string? sd)
|
|
(let ([style-list (get-style-list)])
|
|
(or (send style-list find-named-style sd)
|
|
(send style-list find-named-style "Standard")
|
|
(send style-list find-named-style "Basic")))]
|
|
[sd
|
|
(let* ([style-list (get-style-list)]
|
|
[std (send style-list find-named-style "Standard")])
|
|
(if std
|
|
(send style-list find-or-create-style std sd)
|
|
(let ([basic (send style-list find-named-style "Basic")])
|
|
(send style-list find-or-create-style basic sd))))]))]
|
|
[out-style (add-standard (get-out-style-delta))]
|
|
[err-style (add-standard (get-err-style-delta))]
|
|
[value-style (add-standard (get-value-style-delta))])
|
|
(set! out-port (make-output-port #f
|
|
always-evt
|
|
(make-write-bytes-proc out-style)
|
|
out-close-proc
|
|
(make-write-special-proc out-style)))
|
|
(set! err-port (make-output-port #f
|
|
always-evt
|
|
(make-write-bytes-proc err-style)
|
|
out-close-proc
|
|
(make-write-special-proc err-style)))
|
|
(set! value-port (make-output-port #f
|
|
always-evt
|
|
(make-write-bytes-proc value-style)
|
|
out-close-proc
|
|
(make-write-special-proc value-style)))
|
|
(let ([install-handlers
|
|
(λ (port)
|
|
;; don't want to set the port-print-handler here;
|
|
;; instead drscheme sets the global-port-print-handler
|
|
;; to catch fractions and the like
|
|
(set-interactive-write-handler port)
|
|
(set-interactive-display-handler port))])
|
|
(install-handlers out-port)
|
|
(install-handlers err-port)
|
|
(install-handlers value-port))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; helpers
|
|
;;
|
|
|
|
;; type line-col-pos = (list (union #f fixnum) (union #f fixnum) (union #f fixnum)))
|
|
|
|
;; position->line-col-pos : number -> (list number number number)
|
|
(define/private (position->line-col-pos pos)
|
|
(let* ([para (position-paragraph pos)]
|
|
[para-start (paragraph-start-position para)])
|
|
(list (+ para 1)
|
|
(- pos para-start)
|
|
(+ pos 1))))
|
|
|
|
;; for-each/snips-chars : number number ((union char snip) line-col-pos -> void) -> void
|
|
(define/private (for-each/snips-chars start end func)
|
|
(split-snip start)
|
|
(split-snip end)
|
|
(let loop ([snip (find-snip start 'after-or-none)])
|
|
(cond
|
|
[(not snip) (void)]
|
|
[(< (get-snip-position snip) end)
|
|
(let ([line-col-pos (position->line-col-pos (get-snip-position snip))])
|
|
(cond
|
|
[(is-a? snip string-snip%)
|
|
(let ([str (send snip get-text 0 (send snip get-count))])
|
|
(let loop ([i 0])
|
|
(when (< i (string-length str))
|
|
(func (string-ref str i)
|
|
(list (car line-col-pos)
|
|
(+ i (cadr line-col-pos))
|
|
(+ i (caddr line-col-pos))))
|
|
(loop (+ i 1)))))
|
|
(loop (send snip next))]
|
|
[else
|
|
(func (send snip copy) line-col-pos)
|
|
(loop (send snip next))]))]
|
|
[else (void)])))
|
|
|
|
|
|
;; split-queue : converter (queue (cons (union snip bytes) style)
|
|
;; -> (values (listof (queue (cons (union snip bytes) style)) queue)
|
|
;; this function must only be called on the output-buffer-thread
|
|
;; extracts the viable bytes (and other stuff) from the front of the queue
|
|
;; and returns them as strings (and other stuff).
|
|
(define/private (split-queue converter q)
|
|
(let ([lst (queue->list q)])
|
|
(let loop ([lst lst]
|
|
[acc null])
|
|
(if (null? lst)
|
|
(values (reverse acc)
|
|
(empty-queue))
|
|
(let-values ([(front rest) (peel lst)])
|
|
(cond
|
|
[(not front) (values (reverse acc)
|
|
(empty-queue))]
|
|
[(bytes? (car front))
|
|
(let ([the-bytes (car front)]
|
|
[key (cdr front)])
|
|
(if (null? rest)
|
|
(let-values ([(converted-bytes src-read-k termination)
|
|
(bytes-convert converter the-bytes)])
|
|
(if (eq? termination 'aborts)
|
|
(values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc))
|
|
(enqueue
|
|
(cons (subbytes the-bytes
|
|
(- (bytes-length the-bytes) src-read-k)
|
|
(bytes-length the-bytes))
|
|
key)
|
|
(empty-queue)))
|
|
(values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc))
|
|
(empty-queue))))
|
|
(let-values ([(converted-bytes src-read-k termination)
|
|
(bytes-convert converter the-bytes)]
|
|
[(more-bytes more-termination) (bytes-convert-end converter)])
|
|
(loop rest
|
|
(cons (cons (bytes->string/utf-8 (bytes-append converted-bytes more-bytes))
|
|
key)
|
|
acc)))))]
|
|
[else (loop rest
|
|
(cons front acc))]))))))
|
|
|
|
;; peel : (cons (cons (union snip bytes) X) (listof (cons (union snip bytes) X))
|
|
;; -> (values (cons (union snip bytes) X) (listof (cons (union snip bytes) X)
|
|
;; finds the first segment of bytes with the same style and combines them,
|
|
;; otherwise a lot like (define (peel x) (values (car x) (cdr x)))
|
|
(define/private (peel lst)
|
|
(let loop ([lst lst]
|
|
[acc #f]
|
|
[key #f])
|
|
(cond
|
|
[(null? lst) (values (cons acc key) null)]
|
|
[else
|
|
(let* ([fst (car lst)]
|
|
[fst-key (cdr fst)]
|
|
[fst-val (car fst)])
|
|
(cond
|
|
[(and (not key) (bytes? fst-val))
|
|
(loop (cdr lst)
|
|
fst-val
|
|
fst-key)]
|
|
[(and key (bytes? fst-val) (eq? key fst-key))
|
|
(loop (cdr lst)
|
|
(bytes-append acc fst-val)
|
|
key)]
|
|
[(not key)
|
|
(values fst (cdr lst))]
|
|
[else (if acc
|
|
(values (cons acc key) lst)
|
|
(values fst (cdr lst)))]))])))
|
|
|
|
(super-new)
|
|
(init-output-ports)
|
|
(define-values (in-port read-chan clear-input-chan)
|
|
(start-text-input-port this #f))
|
|
(define-values (in-box-port box-read-chan box-clear-input-chan)
|
|
(start-text-input-port this (lambda () (on-box-peek))))))
|
|
|
|
(define input-box<%>
|
|
(interface ((class->interface text%))
|
|
))
|
|
|
|
(define input-box-mixin
|
|
(mixin ((class->interface text%)) (input-box<%>)
|
|
(inherit erase lock)
|
|
|
|
(define port-text #f)
|
|
(define/public (set-port-text pt) (set! port-text pt))
|
|
|
|
(define in-use? #t)
|
|
(define/public (box-input-not-used-anymore)
|
|
(lock #t)
|
|
(set! in-use? #f))
|
|
|
|
(define/override (on-default-char kevt)
|
|
(super on-default-char kevt)
|
|
(when in-use?
|
|
(case (send kevt get-key-code)
|
|
[(numpad-enter #\return)
|
|
(send port-text new-box-input this)]
|
|
[else (void)])))
|
|
|
|
(super-new)))
|
|
|
|
(define (start-text-input-port source on-peek)
|
|
|
|
;; eventspace at the time this function was called. used for peek callbacks
|
|
(define eventspace (current-eventspace))
|
|
|
|
;; read-chan : (channel (cons (union byte snip eof) line-col-pos))
|
|
;; send input from the editor
|
|
(define read-chan (make-channel))
|
|
|
|
;; clear-input-chan : (channel void)
|
|
(define clear-input-chan (make-channel))
|
|
|
|
;; progress-event-chan : (channel (cons (channel event) nack-evt)))
|
|
(define progress-event-chan (make-channel))
|
|
|
|
;; peek-chan : (channel peeker)
|
|
(define peek-chan (make-channel))
|
|
|
|
;; commit-chan : (channel committer)
|
|
(define commit-chan (make-channel))
|
|
|
|
;; position-chan : (channel (cons (channel void) (channel line-col-pos)))
|
|
(define position-chan (make-channel))
|
|
|
|
(define input-buffer-thread
|
|
(thread
|
|
(λ ()
|
|
|
|
;; these vars are like arguments to the loop function
|
|
;; they are only set right before loop is called.
|
|
;; This is done to avoid passing the same arguments
|
|
;; over and over to loop.
|
|
(define peeker-sema (make-semaphore 0))
|
|
(define peeker-evt (semaphore-peek-evt peeker-sema))
|
|
(define bytes-peeked 0)
|
|
(define response-evts '())
|
|
(define peekers '()) ;; waiting for a peek
|
|
(define committers '()) ;; waiting for a commit
|
|
(define positioners '()) ;; waiting for a position
|
|
(define data (empty-queue)) ;; (queue (cons (union byte snip eof) line-col-pos))
|
|
(define position #f)
|
|
|
|
;; loop : -> alpha
|
|
;; the main loop for this thread
|
|
(define (loop)
|
|
(let-values ([(not-ready-peekers new-peek-response-evts)
|
|
(separate peekers service-waiter)]
|
|
[(potential-commits new-commit-response-evts)
|
|
(separate
|
|
committers
|
|
(service-committer data peeker-evt))])
|
|
(when (and on-peek
|
|
(not (null? not-ready-peekers)))
|
|
(parameterize ([current-eventspace eventspace])
|
|
(queue-callback on-peek)))
|
|
(set! peekers not-ready-peekers)
|
|
(set! committers potential-commits)
|
|
(set! response-evts
|
|
(append response-evts
|
|
new-peek-response-evts
|
|
new-commit-response-evts))
|
|
(sync
|
|
(handle-evt
|
|
position-chan
|
|
(λ (pr)
|
|
(let ([nack-chan (car pr)]
|
|
[resp-chan (cdr pr)])
|
|
(set! positioners (cons pr positioners))
|
|
(loop))))
|
|
(apply choice-evt (map service-positioner positioners))
|
|
(handle-evt
|
|
read-chan
|
|
(λ (ent)
|
|
(set! data (enqueue ent data))
|
|
(unless position
|
|
(set! position (cdr ent)))
|
|
(loop)))
|
|
(handle-evt
|
|
clear-input-chan
|
|
(λ (_)
|
|
(semaphore-post peeker-sema)
|
|
(set! peeker-sema (make-semaphore 0))
|
|
(set! peeker-evt (semaphore-peek-evt peeker-sema))
|
|
(set! data (empty-queue))
|
|
(set! position #f)
|
|
(loop)))
|
|
(handle-evt
|
|
progress-event-chan
|
|
(λ (return-pr)
|
|
(let ([return-chan (car return-pr)]
|
|
[return-nack (cdr return-pr)])
|
|
(set! response-evts
|
|
(cons (choice-evt
|
|
return-nack
|
|
(channel-put-evt return-chan peeker-evt))
|
|
response-evts))
|
|
(loop))))
|
|
(handle-evt
|
|
peek-chan
|
|
(λ (peeker)
|
|
(set! peekers (cons peeker peekers))
|
|
(loop)))
|
|
(handle-evt
|
|
commit-chan
|
|
(λ (committer)
|
|
(set! committers (cons committer committers))
|
|
(loop)))
|
|
(apply
|
|
choice-evt
|
|
(map
|
|
(λ (a-committer)
|
|
(match a-committer
|
|
[($ committer
|
|
kr
|
|
commit-peeker-evt
|
|
done-evt
|
|
resp-chan
|
|
resp-nack)
|
|
(choice-evt
|
|
(handle-evt
|
|
commit-peeker-evt
|
|
(λ (_)
|
|
;; this committer will be thrown out in next iteration
|
|
(loop)))
|
|
(handle-evt
|
|
done-evt
|
|
(λ (v)
|
|
(let ([nth-pos (cdr (peek-n data (- kr 1)))])
|
|
(set! position
|
|
(list (car nth-pos)
|
|
(+ 1 (cadr nth-pos))
|
|
(+ 1 (caddr nth-pos)))))
|
|
(set! data (dequeue-n data kr))
|
|
(semaphore-post peeker-sema)
|
|
(set! peeker-sema (make-semaphore 0))
|
|
(set! peeker-evt (semaphore-peek-evt peeker-sema))
|
|
(set! committers (remq a-committer committers))
|
|
(set! response-evts
|
|
(cons
|
|
(choice-evt
|
|
resp-nack
|
|
(channel-put-evt resp-chan #t))
|
|
response-evts))
|
|
(loop))))]))
|
|
committers))
|
|
(apply choice-evt
|
|
(map (λ (resp-evt)
|
|
(handle-evt
|
|
resp-evt
|
|
(λ (_)
|
|
(set! response-evts (remq resp-evt response-evts))
|
|
(loop))))
|
|
response-evts)))))
|
|
|
|
;; service-positioner : (cons (channel void) (channel line-col-pos)) -> evt
|
|
(define (service-positioner pr)
|
|
(let ([nack-evt (car pr)]
|
|
[resp-evt (cdr pr)])
|
|
(handle-evt
|
|
(choice-evt nack-evt
|
|
(channel-put-evt resp-evt (or position
|
|
|
|
;; a bogus position for when
|
|
;; nothing has happened yet.
|
|
(list 1 0 1))))
|
|
(let ([sent-position position])
|
|
(λ (_)
|
|
(set! positioners (remq pr positioners))
|
|
(loop))))))
|
|
|
|
;; service-committer : queue evt -> committer -> (union #f evt)
|
|
;; if the committer can be dumped, return an evt that
|
|
;; does the dumping. otherwise, return #f
|
|
(define ((service-committer data peeker-evt) a-committer)
|
|
(match a-committer
|
|
[($ committer
|
|
kr commit-peeker-evt
|
|
done-evt resp-chan resp-nack)
|
|
(let ([size (queue-size data)])
|
|
(cond
|
|
[(not (eq? peeker-evt commit-peeker-evt))
|
|
(choice-evt
|
|
resp-nack
|
|
(channel-put-evt resp-chan #f))]
|
|
[(< size kr)
|
|
(choice-evt
|
|
resp-nack
|
|
(channel-put-evt resp-chan 'commit-failure))]
|
|
[else ;; commit succeeds
|
|
#f]))]))
|
|
|
|
;; service-waiter : peeker -> (union #f evt)
|
|
;; if the peeker can be serviced, build an event to service it
|
|
;; otherwise return #f
|
|
(define (service-waiter a-peeker)
|
|
(match a-peeker
|
|
[($ peeker bytes skip-count pe resp-chan nack-evt polling?)
|
|
(cond
|
|
[(and pe (not (eq? pe peeker-evt)))
|
|
(choice-evt (channel-put-evt resp-chan #f)
|
|
nack-evt)]
|
|
[((queue-size data) . > . skip-count)
|
|
(let ([nth (car (peek-n data skip-count))])
|
|
(choice-evt
|
|
nack-evt
|
|
(cond
|
|
[(byte? nth)
|
|
(bytes-set! bytes 0 nth)
|
|
(channel-put-evt resp-chan 1)]
|
|
[(eof-object? nth)
|
|
(channel-put-evt resp-chan nth)]
|
|
[else
|
|
(channel-put-evt
|
|
resp-chan
|
|
(λ (src line col pos)
|
|
(if (is-a? nth readable-snip<%>)
|
|
(send nth read-special src line col pos)
|
|
nth)))])))]
|
|
[polling?
|
|
(choice-evt
|
|
nack-evt
|
|
(channel-put-evt resp-chan 0))]
|
|
[else
|
|
#f])]))
|
|
|
|
;; separate (listof X) (X -> (union #f Y)) -> (values (listof X) (listof Y))
|
|
;; separates `eles' into two lists -- those that `f' returns #f for
|
|
;; and then the results of calling `f' for those where `f' doesn't return #f
|
|
(define (separate eles f)
|
|
(let loop ([eles eles]
|
|
[transformed '()]
|
|
[left-alone '()])
|
|
(cond
|
|
[(null? eles) (values left-alone transformed)]
|
|
[else (let* ([ele (car eles)]
|
|
[maybe (f ele)])
|
|
(if maybe
|
|
(loop (cdr eles)
|
|
(cons maybe transformed)
|
|
left-alone)
|
|
(loop (cdr eles)
|
|
transformed
|
|
(cons ele left-alone))))])))
|
|
|
|
;;; start things going
|
|
(loop))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; the following must be able to run
|
|
;; in any thread (even concurrently)
|
|
;;
|
|
(define (read-bytes-proc bstr)
|
|
(let* ([progress-evt (progress-evt-proc)]
|
|
[v (peek-proc bstr 0 progress-evt)])
|
|
(cond
|
|
[(sync/timeout 0 progress-evt)
|
|
0]
|
|
[else
|
|
(wrap-evt
|
|
v
|
|
(λ (v)
|
|
(if (and (number? v) (zero? v))
|
|
0
|
|
(if (commit-proc (if (number? v) v 1)
|
|
progress-evt
|
|
always-evt)
|
|
v
|
|
0))))])))
|
|
|
|
(define (peek-proc bstr skip-count progress-evt)
|
|
(poll-guard-evt
|
|
(lambda (polling?)
|
|
(let ([evt
|
|
(nack-guard-evt
|
|
(λ (nack)
|
|
(let ([chan (make-channel)])
|
|
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack polling?))
|
|
chan)))])
|
|
(if polling?
|
|
(let ([v (sync evt)])
|
|
(if (eq? v 0)
|
|
;; Don't return 0, because that means something is
|
|
;; probably ready. We want to indicate that nothing is
|
|
;; ready.
|
|
never-evt
|
|
;; Even on success, package it as an event, because
|
|
;; `read-bytes-proc' expects an event
|
|
(wrap-evt always-evt (lambda (_) v))))
|
|
evt)))))
|
|
|
|
(define (progress-evt-proc)
|
|
(sync
|
|
(nack-guard-evt
|
|
(λ (nack)
|
|
(let ([chan (make-channel)])
|
|
(channel-put progress-event-chan (cons chan nack))
|
|
chan)))))
|
|
|
|
(define (commit-proc kr progress-evt done-evt)
|
|
(sync
|
|
(nack-guard-evt
|
|
(λ (nack)
|
|
(let ([chan (make-channel)])
|
|
(channel-put commit-chan (make-committer kr progress-evt done-evt chan nack))
|
|
chan)))))
|
|
|
|
(define (close-proc) (void))
|
|
|
|
(define (position-proc)
|
|
(let ([chan (make-channel)])
|
|
(apply
|
|
values
|
|
(sync
|
|
(nack-guard-evt
|
|
(λ (fail)
|
|
(channel-put position-chan (cons fail chan))
|
|
chan))))))
|
|
(let ([p (make-input-port source
|
|
read-bytes-proc
|
|
peek-proc
|
|
close-proc
|
|
progress-evt-proc
|
|
commit-proc
|
|
position-proc)])
|
|
(port-count-lines! p)
|
|
(values p read-chan clear-input-chan)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; queues
|
|
;;
|
|
(define-struct queue (front back count))
|
|
(define (empty-queue) (make-queue '() '() 0))
|
|
(define (enqueue e q) (make-queue
|
|
(cons e (queue-front q))
|
|
(queue-back q)
|
|
(+ (queue-count q) 1)))
|
|
(define (queue-first q)
|
|
(flip-around q)
|
|
(let ([back (queue-back q)])
|
|
(if (null? back)
|
|
(error 'queue-first "empty queue")
|
|
(car back))))
|
|
(define (queue-rest q)
|
|
(flip-around q)
|
|
(let ([back (queue-back q)])
|
|
(if (null? back)
|
|
(error 'queue-rest "empty queue")
|
|
(make-queue (queue-front q)
|
|
(cdr back)
|
|
(- (queue-count q) 1)))))
|
|
(define (flip-around q)
|
|
(when (null? (queue-back q))
|
|
(set-queue-back! q (reverse (queue-front q)))
|
|
(set-queue-front! q '())))
|
|
|
|
(define (queue-empty? q) (zero? (queue-count q)))
|
|
(define (queue-size q) (queue-count q))
|
|
|
|
;; queue->list : (queue x) -> (listof x)
|
|
;; returns the elements in the order that successive deq's would have
|
|
(define (queue->list q)
|
|
(let ([ans (append (queue-back q) (reverse (queue-front q)))])
|
|
(set-queue-back! q ans)
|
|
(set-queue-front! q '())
|
|
ans))
|
|
|
|
;; dequeue-n : queue number -> queue
|
|
(define (dequeue-n queue n)
|
|
(let loop ([q queue]
|
|
[n n])
|
|
(cond
|
|
[(zero? n) q]
|
|
[(queue-empty? q) (error 'dequeue-n "not enough!")]
|
|
[else (loop (queue-rest q) (- n 1))])))
|
|
|
|
;; peek-n : queue number -> queue
|
|
(define (peek-n queue init-n)
|
|
(let loop ([q queue]
|
|
[n init-n])
|
|
(cond
|
|
[(zero? n)
|
|
(when (queue-empty? q)
|
|
(error 'peek-n "not enough; asked for ~a but only ~a available"
|
|
init-n
|
|
(queue-size queue)))
|
|
(queue-first q)]
|
|
[else
|
|
(when (queue-empty? q)
|
|
(error 'dequeue-n "not enough!"))
|
|
(loop (queue-rest q) (- n 1))])))
|
|
|
|
;;
|
|
;; end queue abstraction
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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 wide-snip% (wide-snip-mixin basic%))
|
|
(define standard-style-list% (editor:standard-style-list-mixin wide-snip%))
|
|
(define input-box% (input-box-mixin standard-style-list%))
|
|
(define -keymap% (editor:keymap-mixin standard-style-list%))
|
|
(define return% (return-mixin -keymap%))
|
|
(define autowrap% (editor:autowrap-mixin -keymap%))
|
|
(define file% (file-mixin (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%))))
|