(module mred-callback mzscheme
(require (lib "etc.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
"utilities.ss"
"long-prefix.ss"
"rope.ss"
"gui/text-rope-mixin.ss")
(provide
focus-callback-mixin
insert-and-delete-callback-mixin
set-position/preserving-marks-callback-mixin
voice-mred-text-callback-mixin
voice-mred-interactions-text-callback-mixin
)
(define diva-debug false)
(define (diva-printf text . args)
(when diva-debug
(apply printf text args)))
(define (focus-callback-mixin super%)
(class super%
(define/override (on-focus on?)
(super on-focus on?)
(unless on?
(diva:-on-loss-focus)))
(define on-loss-focus (lambda () ()))
(define/public (diva:-set-on-loss-focus fun)
(set! on-loss-focus fun))
(define/public (diva:-on-loss-focus)
(on-loss-focus))
(super-new)))
(define (insert-and-delete-callback-mixin super%)
(class super%
(define after-insert-callback (lambda (start end) (void)))
(define after-delete-callback (lambda (start end) (void)))
(define/public (diva:-set-after-insert-callback fun)
(set! after-insert-callback fun))
(define/augment (after-insert start end)
(after-insert-callback start end)
(inner void after-insert start end))
(define/public (diva:-set-after-delete-callback fun)
(set! after-delete-callback fun))
(define/augment (after-delete start end)
(after-delete-callback start end)
(inner void after-delete start end))
(super-new)))
(define (set-position/preserving-marks-callback-mixin super%)
(class super%
(inherit highlight-range get-text)
(define insertion-after-set-position-callback-old
(lambda () ()))
(define insertion-after-set-position-callback
insertion-after-set-position-callback-old)
(define/public (diva:-insertion-after-set-position-callback-set callback)
(set! insertion-after-set-position-callback-old
insertion-after-set-position-callback)
(set! insertion-after-set-position-callback callback))
(define/public (diva:-insertion-after-set-position-callback-reset)
(set! insertion-after-set-position-callback
insertion-after-set-position-callback-old))
(define/augment (after-set-position)
(insertion-after-set-position-callback))
(define/augment (after-insert start len)
(inner void after-insert start len)
(preserve-mark start len))
(define/augment (after-delete start len)
(inner void after-delete start len)
(preserve-mark start (- len)))
(define mark-start-position 0)
(define mark-end-position 0)
(define/public (diva:-get-mark-start-position)
mark-start-position)
(define/public (diva:-get-mark-end-position)
mark-end-position)
(define/public (diva:-set-mark start-pos end-pos)
(hide-mark)
(set! mark-start-position start-pos)
(set! mark-end-position end-pos)
(show-mark))
(define mark-color (send the-color-database find-color "Orange"))
(define (show-mark)
(unless (= mark-start-position mark-end-position)
(set! hide-mark
(highlight-range mark-start-position
mark-end-position
mark-color))))
(define hide-mark (lambda () ()))
(define (preserve-mark start delta)
(hide-mark)
(when (<= start mark-start-position)
(set! mark-start-position (+ mark-start-position delta))
(set! mark-end-position (+ mark-end-position delta)))
(unless (and (legal-mark-pos? mark-start-position)
(legal-mark-pos? mark-end-position))
(set! mark-start-position 0)
(set! mark-end-position 0))
(show-mark))
(define (legal-mark-pos? pos)
(<= 0 pos (string-length (get-text))))
(super-new)))
(define (voice-mred-text-callback-mixin super%)
(class super%
(super-instantiate ())
(inherit can-insert? delete begin-edit-sequence end-edit-sequence)
(define/public (diva:-get-rope)
(send this get-rope))
(define/public (diva:-update-text text)
(dynamic-wind
(lambda () (begin-edit-sequence))
(lambda () (update-text text))
(lambda () (end-edit-sequence))))
(define (update-text to-text)
(let ([from-text (send this diva:-get-rope)])
(unless (rope=? to-text from-text)
(let*-values
([(start-length end-length)
(common-prefix&suffix-lengths (rope->vector from-text)
(rope->vector to-text)
vector-length
vector-ref
equal?)]
[(from-end)
(- (rope-length from-text) end-length)]
[(to-end)
(- (rope-length to-text) end-length)]
[(insert-text) (subrope to-text start-length to-end)])
(cond
[(rope=? (subrope from-text start-length from-end)
insert-text)
(void)]
[(can-insert? start-length from-end)
(begin-edit-sequence)
(delete start-length from-end #f)
(send this set-position start-length 'same #f #f 'local)
(insert-rope-in-text this insert-text)
(end-edit-sequence)]
[else
(raise (make-voice-exn
"I cannot edit the text. Text is read-only."))])))))))
(define (voice-mred-interactions-text-callback-mixin super%)
(class (voice-mred-text-callback-mixin super%)
(super-instantiate ())
(inherit get-rope
get-text
get-unread-start-point)
(define/override (diva:-update-text text)
(super diva:-update-text text)
(define (rehydrate-prompts-in-text text)
(regexp-replace* "(^|\n)>($|\n)" text "\\1> \\2"))
(super diva:-update-text (rehydrate-prompts-in-text text)))
(define/override (diva:-get-rope)
(define (all-but-last text)
(substring text 0 (sub1 (string-length text))))
(define (last-char text)
(string-ref text (sub1 (string-length text))))
(define (hide-annotations annotated-text)
(cond
[(and (> (string-length annotated-text) 0)
(char-whitespace? (last-char annotated-text)))
(string-append
(string-convert-non-control-chars
(all-but-last annotated-text) #\X)
(string (last-char annotated-text)))]
[else
(string-convert-non-control-chars annotated-text #\X)]))
(let ([a-rope (get-rope)]
[text (get-text)])
(rope-append
(string->rope
(hide-annotations (substring text 0 (get-unread-start-point))))
(subrope a-rope (get-unread-start-point)))))))
)