5615 lines
259 KiB
Racket
5615 lines
259 KiB
Racket
#lang scheme/base
|
|
(require scheme/class
|
|
scheme/port
|
|
scheme/file
|
|
(for-syntax scheme/base)
|
|
"../syntax.ss"
|
|
"const.ss"
|
|
"mline.ss"
|
|
"private.ss"
|
|
"editor.ss"
|
|
"undo.ss"
|
|
"style.ss"
|
|
"snip.ss"
|
|
"snip-flags.ss"
|
|
"snip-admin.ss"
|
|
"keymap.ss"
|
|
(only-in "cycle.ss" set-text%!)
|
|
"wordbreak.ss"
|
|
"stream.ss"
|
|
"wx.ss")
|
|
|
|
(provide text%
|
|
add-text-keymap-functions)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define flash-timer%
|
|
(class timer%
|
|
(init editor)
|
|
(define for-editor editor)
|
|
(super-new)
|
|
(define/override (notify)
|
|
(send for-editor flash-off))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define arrow (make-object cursor% 'arrow))
|
|
(define i-beam (make-object cursor% 'ibeam))
|
|
|
|
(define MAX-COUNT-FOR-SNIP 500)
|
|
(define A-VERY-BIG-NUMBER 1e50)
|
|
|
|
(define TAB-WIDTH 20.0)
|
|
|
|
(define show-outline-for-inactive?
|
|
(and (get-preference 'MrEd:outline-inactive-selection) #t))
|
|
|
|
(define caret-pen (send the-pen-list find-or-create-pen "BLACK" 1 'xor))
|
|
(define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent))
|
|
(define outline-inactive-pen (send the-pen-list find-or-create-pen "BLACK" 1 'hilite))
|
|
(define outline-brush (send the-brush-list find-or-create-brush "BLACK" 'hilite))
|
|
(define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0")
|
|
(define outline-nonowner-brush (let ([b (new brush%)])
|
|
(send b set-color "BLACK")
|
|
(send b set-stipple (make-object bitmap% xpattern 16 16))
|
|
(send b set-style 'xor)
|
|
b))
|
|
(define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
|
|
|
|
(define (showcaret>= a b)
|
|
(memq a (memq b '(no-caret show-inactive-caret show-caret))))
|
|
|
|
(define-struct clickback (start end f call-on-down? delta hilited? unhilite) #:mutable)
|
|
|
|
(defclass text% editor%
|
|
(inherit-field s-admin
|
|
s-offscreen
|
|
s-custom-cursor
|
|
s-custom-cursor-overrides?
|
|
s-keymap
|
|
s-own-caret?
|
|
s-style-list
|
|
s-user-locked?
|
|
s-modified?
|
|
s-noundomode
|
|
s-caret-snip
|
|
s-inactive-caret-threshold
|
|
s-filename
|
|
s-temp-filename?
|
|
s-need-on-display-size?)
|
|
(inherit on-change
|
|
on-local-event
|
|
on-local-char
|
|
scroll-editor-to
|
|
free-old-copies
|
|
install-copy-buffer
|
|
begin-copy-buffer
|
|
end-copy-buffer
|
|
do-buffer-paste
|
|
copy-ring-next
|
|
do-write-headers-footers
|
|
do-set-caret-owner
|
|
perform-undo-list
|
|
s-start-intercept
|
|
s-end-intercept
|
|
do-own-x-selection
|
|
copy-out-x-selection
|
|
add-undo-rec
|
|
set-modified
|
|
get-default-style
|
|
get-snip-data
|
|
set-snip-data
|
|
read-snips-from-file
|
|
on-paint
|
|
on-focus
|
|
default-style-name
|
|
wait-sequence-lock
|
|
begin-sequence-lock
|
|
end-sequence-lock
|
|
do-own-caret
|
|
on-edit-sequence
|
|
after-edit-sequence
|
|
on-display-size)
|
|
|
|
(define read-locked? #t)
|
|
(define flow-locked? #t)
|
|
(define write-locked? #t)
|
|
|
|
(define hilite-on? #t)
|
|
|
|
(define changed? #f) ;; set if on-change() needs to be called
|
|
|
|
(define flash? #f)
|
|
(define flashautoreset? #f)
|
|
(define flashdirectoff? #f)
|
|
|
|
(define posateol? #f) ;; display the caret at the end of a line?
|
|
(define flashposateol? #f)
|
|
(define flashscroll? #f) ;; scroll back after unflashing?
|
|
|
|
(define graphics-invalid? #f)
|
|
(define flow-invalid? #f)
|
|
(define snip-cache-invalid? #f)
|
|
(define graphic-maybe-invalid? #f)
|
|
(define graphic-maybe-invalid-force? #f)
|
|
|
|
(define typing-streak? #f)
|
|
(define deletion-streak? #f)
|
|
(define delayed-streak? #f)
|
|
(define vcursor-streak? #f)
|
|
(define kill-streak? #f)
|
|
(define anchor-streak? #f)
|
|
(define extend-streak? #f)
|
|
(define insert-force-streak? #f)
|
|
(define delete-force-streak? #f)
|
|
|
|
(define keep-anchor-streak? #f)
|
|
|
|
(define streaks-pushed? #f)
|
|
(define save-typing-streak? #f)
|
|
(define save-deletion-streak? #f)
|
|
(define save-delayed-streak? #f)
|
|
(define save-vcursor-streak? #f)
|
|
(define save-kill-streak? #f)
|
|
(define save-anchor-streak? #f)
|
|
(define save-extend-streak? #f)
|
|
|
|
(define dragging? #f)
|
|
(define tracking? #f)
|
|
(define extra-line? #f) ;; empty line at end of file with no representative
|
|
|
|
(define delayedscrollateol? #f)
|
|
(define delayedscrollbox? #f)
|
|
(define draw-cached-in-bitmap? #f)
|
|
(define refresh-unset? #f)
|
|
(define refresh-box-unset? #f)
|
|
(define refresh-all? #f)
|
|
|
|
(define tab-space-in-units? #f)
|
|
(define sticky-styles? #t)
|
|
(define overwrite-mode? #f)
|
|
|
|
(def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? (and s? #t)))
|
|
(def/public (get-styles-sticky) sticky-styles?)
|
|
|
|
(def/public (get-overwrite-mode) overwrite-mode?)
|
|
(def/public (set-overwrite-mode [bool? v]) (set! overwrite-mode? (and v #t)))
|
|
|
|
(def/public (get-sticky-styles) sticky-styles?)
|
|
(def/public (set-sticky-styles [bool? v]) (set! sticky-styles? (and v #t)))
|
|
|
|
(define need-x-copy? #f)
|
|
|
|
(define caret-blinked? #f) ;; whether we want to hide an active caret or not
|
|
|
|
(define initial-style-needed? #t)
|
|
|
|
(define last-draw-caret 0)
|
|
(define last-draw-x-sel? #f)
|
|
|
|
(define max-width 0.0)
|
|
(define min-width 0.0)
|
|
(define max-height 0.0)
|
|
(define min-height 0.0)
|
|
(define wrap-bitmap-width 0.0)
|
|
|
|
(define auto-wrap-bitmap #f)
|
|
|
|
(define delay-refresh 0)
|
|
|
|
(define len 0) ; total length in "characters" == number of positions - 1
|
|
|
|
(define startpos 0)
|
|
(define endpos 0)
|
|
(define extendstartpos 0)
|
|
(define extendendpos 0) ; for extendstreak
|
|
(define vcursorloc 0.0) ; for vcursor-streak
|
|
|
|
(define flash-timer #f)
|
|
(define flashstartpos 0)
|
|
(define flashendpos 0)
|
|
|
|
(define snips #f)
|
|
(define last-snip #f) ; the contents of this edit session
|
|
(define snip-count 0)
|
|
|
|
(define snip-admin (new standard-snip-admin% [editor this]))
|
|
|
|
(define line-root-box (box #f))
|
|
(define first-line #f)
|
|
(define last-line #f)
|
|
(define num-valid-lines 0)
|
|
|
|
(define extra-line-h 0.0)
|
|
|
|
(define total-height 0.0) ; total height/width in canvas units
|
|
(define total-width 0.0)
|
|
(define final-descent 0.0) ; descent of last line
|
|
(define initial-space 0.0) ; space from first line
|
|
(define initial-line-base 0.0) ; inverse descent from first line
|
|
|
|
(define/public (get-s-snips) snips)
|
|
(define/public (get-s-last-snip) last-snip)
|
|
(define/public (get-s-total-width) total-width)
|
|
(define/public (get-s-total-height) total-height)
|
|
|
|
(define/public (consistent-snip-lines who)
|
|
(unless (eq? first-line (mline-first (unbox line-root-box)))
|
|
(error who "bad first line"))
|
|
(unless (eq? last-line (mline-last (unbox line-root-box)))
|
|
(error who "bad last line"))
|
|
(let loop ([line first-line]
|
|
[snip snips]
|
|
[snip-num 0])
|
|
(unless (eq? snips (mline-snip first-line))
|
|
(error who "bad start snip"))
|
|
(let sloop ([snip snip][snip-num snip-num])
|
|
(when (zero? (snip->count snip))
|
|
(unless (zero? len)
|
|
(error who "snip count is 0 at ~s" snip-num)))
|
|
(unless (eq? line (snip->line snip))
|
|
(error who "snip's line is wrong: ~s ~s" snip (snip->line snip)))
|
|
(if (eq? snip (mline-last-snip line))
|
|
(if (mline-next line)
|
|
(begin
|
|
(unless (has-flag? (snip->flags snip) NEWLINE)
|
|
(error who "strange line ending"))
|
|
(loop (mline-next line) (snip->next snip) (add1 snip-num)))
|
|
(unless (eq? last-snip snip)
|
|
(error who "bad last snip")))
|
|
(begin
|
|
(when (or (has-flag? (snip->flags snip) NEWLINE)
|
|
(has-flag? (snip->flags snip) HARD-NEWLINE))
|
|
(error who "mid-line NEWLINE"))
|
|
(sloop (snip->next snip) (add1 snip-num))))))
|
|
#t)
|
|
|
|
(define caret-style #f)
|
|
|
|
(define dragstart 0)
|
|
|
|
(define track-clickback #f)
|
|
|
|
(define refresh-start 0)
|
|
(define refresh-end 0)
|
|
(define refresh-l 0.0)
|
|
(define refresh-t 0.0)
|
|
(define refresh-r 0.0)
|
|
(define refresh-b 0.0)
|
|
|
|
(define last-draw-l 0.0)
|
|
(define last-draw-t 0.0)
|
|
(define last-draw-r 0.0)
|
|
(define last-draw-b 0.0)
|
|
(define last-draw-red 0)
|
|
(define last-draw-green 0)
|
|
(define last-draw-blue 0)
|
|
|
|
(define delayedscroll -1)
|
|
(define delayedscrollend 0)
|
|
(define delayedscrollbias 'none)
|
|
(define delayedscrollsnip #f)
|
|
(define delayedscroll-x 0.0)
|
|
(define delayedscroll-y 0.0)
|
|
(define delayedscroll-w 0.0)
|
|
(define delayedscroll-h 0.0)
|
|
|
|
(define clickbacks null)
|
|
|
|
(define file-format 'standard)
|
|
|
|
(define between-threshold 2.0)
|
|
|
|
(define tab-space TAB-WIDTH) ; inexact
|
|
|
|
(define read-insert 0)
|
|
(define read-insert-start 0)
|
|
|
|
(define prev-paste-start 0)
|
|
(define prev-paste-end 0)
|
|
(define save-prev-paste-start 0)
|
|
(define save-prev-paste-end 0)
|
|
|
|
(define revision-count 0.0)
|
|
|
|
(define word-break standard-wordbreak)
|
|
(define word-break-map the-editor-wordbreak-map)
|
|
|
|
(define offscreen-key (gensym))
|
|
|
|
(init [(ls line-spacing) 1.0]
|
|
[tab-stops null]
|
|
[auto-wrap #f])
|
|
|
|
(super-new)
|
|
|
|
(define line-spacing ls)
|
|
(define/public (get-s-line-spacing) line-spacing)
|
|
(define tabs (list->vector tab-stops))
|
|
|
|
(make-only-snip)
|
|
|
|
(set! read-locked? #f)
|
|
(set! flow-locked? #f)
|
|
(set! write-locked? #f)
|
|
;;; from here on, it is only method definitions,
|
|
;;; so we can unlock the editor now. If code with
|
|
;;; effects is added below, be sure to move the
|
|
;;; unlocking.
|
|
|
|
(def/override (~)
|
|
(set! word-break-map standard-wordbreak)
|
|
(let loop ([snip snips])
|
|
(when snip
|
|
(let ([next (snip->next snip)])
|
|
(send snip ~)
|
|
(loop next))))
|
|
(set! snips #f)
|
|
(set! clickbacks null))
|
|
|
|
(def/override (copy-self)
|
|
(let ([m (new text% [line-spacing line-spacing])])
|
|
(copy-self-to m)
|
|
m))
|
|
|
|
(def/override (copy-self-to [editor<%> m])
|
|
(when (m . is-a? . text%)
|
|
;; copy parameters, such as tab settings: */
|
|
(send m set-tabs (vector->list tabs) tab-space tab-space-in-units?)
|
|
(super copy-self-to m)
|
|
(when (zero? (send m last-position))
|
|
;; make sure only snip in m has a good style (since we called
|
|
;; (send m->style-list copy) in copy-self-to).
|
|
(let* ([sname (default-style-name)]
|
|
[bs (send (send m get-s-style-list) find-named-style sname)])
|
|
(set-snip-style! (send m get-s-snips)
|
|
(or bs
|
|
(send (send m get-s-style-list) basic-style)))))
|
|
|
|
(send m set-file-format (get-file-format))
|
|
|
|
(send m set-wordbreak-func word-break)
|
|
(send m set-wordbreak-map (get-wordbreak-map))
|
|
(send m set-between-threshold (get-between-threshold))
|
|
(send m hide-caret (caret-hidden?))
|
|
(send m set-overwrite-mode (get-overwrite-mode))
|
|
|
|
(send m set-autowrap-bitmap auto-wrap-bitmap)
|
|
|
|
(send m set-sticky-styles sticky-styles?)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/override (adjust-cursor [mouse-event% event])
|
|
(if (not s-admin)
|
|
#f
|
|
(let-boxes ([scrollx 0.0]
|
|
[scrolly 0.0]
|
|
[dc #f])
|
|
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
|
(if (not dc)
|
|
#f
|
|
(let ([x (+ (send event get-x) scrollx)]
|
|
[y (+ (send event get-y) scrolly)])
|
|
(if tracking?
|
|
(or s-custom-cursor arrow)
|
|
(if (too-busy-to-refresh?)
|
|
;; we're too busy; ask again later
|
|
(or (and s-custom-cursor-overrides? s-custom-cursor)
|
|
i-beam)
|
|
(begin
|
|
(begin-sequence-lock)
|
|
(begin0
|
|
(or (and (not s-custom-cursor-overrides?)
|
|
(or (and s-caret-snip (send event dragging?)
|
|
(let-boxes ([x 0.0]
|
|
[y 0.0])
|
|
(get-snip-position-and-location s-caret-snip #f x y)
|
|
(let ([c (send s-caret-snip adjust-cursor dc
|
|
(- x scrollx) (- y scrolly)
|
|
x y event)])
|
|
c)))
|
|
;; find snip:
|
|
(let-boxes ([onit? #f]
|
|
[how-close 0.0]
|
|
[pos 0])
|
|
(set-box! pos (find-position x y #f onit? how-close))
|
|
;; FIXME: the following refinement of `onit?' seems pointless
|
|
(let ([onit? (and onit?
|
|
(not (zero? how-close))
|
|
((abs how-close) . > . between-threshold))])
|
|
(let ([snip (and onit?
|
|
(do-find-snip pos 'after))])
|
|
(and snip
|
|
(let-boxes ([x 0.0] [y 0.0])
|
|
(get-snip-position-and-location snip #f x y)
|
|
(let ([c (send snip adjust-cursor dc (- x scrollx) (- y scrolly)
|
|
x y event)])
|
|
c))))))))
|
|
s-custom-cursor
|
|
(if (x . >= . 0)
|
|
(let ([cb? (find-clickback (find-position x y #f) y)])
|
|
(if cb? arrow i-beam))
|
|
i-beam))
|
|
(end-sequence-lock))))))))))
|
|
|
|
(def/override (on-event [mouse-event% event])
|
|
(when s-admin
|
|
(when (and (not (send event moving?))
|
|
(not (send event entering?))
|
|
(not (send event leaving?)))
|
|
(end-streaks '(except-key-sequence cursor delayed)))
|
|
(let-values ([(dc x y scrollx scrolly)
|
|
(if (or (send event button-down?) s-caret-snip)
|
|
;; first, find clicked-on snip:
|
|
(let ([x (send event get-x)]
|
|
[y (send event get-y)])
|
|
(let-boxes ([scrollx 0.0]
|
|
[scrolly 0.0]
|
|
[dc #f])
|
|
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
|
;; FIXME: old code returned if !dc
|
|
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
|
|
(values #f 0.0 0.0 0.0 0.0))])
|
|
(when (send event button-down?)
|
|
(let ([snip
|
|
(let-boxes ([onit? #f]
|
|
[how-close 0.0]
|
|
[now 0])
|
|
(set-box! now (find-position x y #f onit? how-close))
|
|
;; FIXME: the following refinement of `onit?' seems pointless
|
|
(let ([onit? (and onit?
|
|
(not (zero? how-close))
|
|
((abs how-close) . > . between-threshold))])
|
|
(if onit?
|
|
;; we're in the snip's horizontal region...
|
|
(let ([snip (do-find-snip now 'after)])
|
|
;; ... but maybe the mouse is above or below it.
|
|
(let-boxes ([top 0.0]
|
|
[bottom 0.0]
|
|
[dummy 0.0])
|
|
(begin
|
|
(get-snip-location snip dummy top #f)
|
|
(get-snip-location snip dummy bottom #t))
|
|
(if (or (top . > . y) (y . > . bottom))
|
|
#f
|
|
snip)))
|
|
#f)))])
|
|
(set-caret-owner snip)))
|
|
(if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS))
|
|
(let-boxes ([x 0.0] [y 0.0])
|
|
(get-snip-position-and-location s-caret-snip #f x y)
|
|
(send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event))
|
|
(on-local-event event)))))
|
|
|
|
(def/override (on-default-event [mouse-event% event])
|
|
(when s-admin
|
|
(let-boxes ([scrollx 0.0]
|
|
[scrolly 0.0]
|
|
[dc #f])
|
|
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
|
(let ([x (+ (send event get-x) scrollx)]
|
|
[y (+ (send event get-y) scrolly)])
|
|
(when dc
|
|
|
|
(let-boxes ([now 0]
|
|
[ateol? #f]
|
|
[how-close 0.0])
|
|
(set-box! now (find-position x y ateol? #f how-close))
|
|
(let ([now (if (and (how-close . > . 0)
|
|
(how-close . <= . between-threshold))
|
|
(add1 now)
|
|
now)])
|
|
(cond
|
|
[(send event button-down?)
|
|
(set! tracking? #f)
|
|
(let ([click (and (x . >= . 0) (find-clickback now y))])
|
|
(if click
|
|
(if (clickback-call-on-down? click)
|
|
((clickback-f click) this (clickback-start click) (clickback-end click))
|
|
(begin
|
|
(set! tracking? #t)
|
|
(set! track-clickback click)
|
|
(when s-admin
|
|
(send s-admin update-cursor))
|
|
(set-clickback-hilited?! track-clickback #t)))
|
|
(begin
|
|
(set! dragstart now)
|
|
(set! dragging? #t)
|
|
(when (send event get-shift-down)
|
|
(if (dragstart . > . startpos)
|
|
(set! dragstart startpos)
|
|
(set! dragstart endpos)))
|
|
(if (now . < . dragstart)
|
|
(set-position-bias-scroll 'start-only now dragstart ateol?)
|
|
(set-position-bias-scroll 'end-only dragstart now ateol?)))))]
|
|
[(send event dragging?)
|
|
(cond
|
|
[dragging?
|
|
(if (now . < . dragstart)
|
|
(when (or (not (= startpos now)) (not (= endpos dragstart)))
|
|
(set-position-bias-scroll 'start-only now dragstart ateol?))
|
|
(when (or (not (= endpos now)) (not (= startpos dragstart)))
|
|
(set-position-bias-scroll 'end-only dragstart now ateol?)))]
|
|
[tracking?
|
|
(let ([cb (if (x . >= . 0)
|
|
(find-clickback now y)
|
|
#f)])
|
|
(set-clickback-hilited?! track-clickback (eq? cb track-clickback)))])]
|
|
[(send event button-up?)
|
|
(cond
|
|
[dragging?
|
|
(set! dragging? #f)]
|
|
[tracking?
|
|
(set! tracking? #f)
|
|
(when (clickback-hilited? track-clickback)
|
|
(set-clickback-hilited?! track-clickback #f)
|
|
(let ([click track-clickback])
|
|
((clickback-f click) this (clickback-start click) (clickback-end click))))
|
|
(when s-admin
|
|
(send s-admin update-cursor))])]
|
|
[(send event moving?)
|
|
(set! dragging? #f)
|
|
(when tracking?
|
|
(set! tracking? #f)
|
|
(when (clickback-hilited? track-clickback)
|
|
(set-clickback-hilited?! track-clickback #f)
|
|
(let ([click track-clickback])
|
|
((clickback-f click) this (clickback-start click) (clickback-end click)))))
|
|
(when s-admin
|
|
(send s-admin update-cursor))]))))))))
|
|
|
|
(def/override (on-char [key-event% event])
|
|
(when s-admin
|
|
(if (and s-caret-snip
|
|
(has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS))
|
|
(let-boxes ([scrollx 0.0]
|
|
[scrolly 0.0]
|
|
[dc #f])
|
|
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
|
(let-boxes ([x 0.0] [y 0.0])
|
|
(get-snip-position-and-location s-caret-snip #f x y)
|
|
(send s-caret-snip on-char dc (- x scrollx) (- y scrolly) x y event)))
|
|
(let ([code (send event get-key-code)])
|
|
(when (and (not (eq? 'release code))
|
|
(not (eq? 'shift code))
|
|
(not (eq? 'control code))
|
|
(not (eq? 'menu code))
|
|
(not (equal? code #\nul)))
|
|
(hide-cursor))
|
|
(on-local-char event)))))
|
|
|
|
(def/override (on-default-char [key-event% event])
|
|
(when s-admin
|
|
(let ([code (send event get-key-code)]
|
|
[ins (lambda (ch)
|
|
(if (and overwrite-mode? (= endpos startpos))
|
|
(insert ch startpos (add1 startpos))
|
|
(insert ch)))])
|
|
(case code
|
|
[(#\backspace) (delete)]
|
|
[(#\rubout)
|
|
(if (= endpos startpos)
|
|
(when (endpos . < . len)
|
|
(delete endpos (add1 endpos)))
|
|
(delete))]
|
|
[(right left up down home end prior next)
|
|
(move-position code (send event get-shift-down))]
|
|
[(numpad0) (ins #\0)]
|
|
[(numpad1) (ins #\1)]
|
|
[(numpad2) (ins #\2)]
|
|
[(numpad3) (ins #\3)]
|
|
[(numpad4) (ins #\4)]
|
|
[(numpad5) (ins #\5)]
|
|
[(numpad6) (ins #\6)]
|
|
[(numpad7) (ins #\7)]
|
|
[(numpad8) (ins #\8)]
|
|
[(numpad9) (ins #\9)]
|
|
[(multiply) (ins #\*)]
|
|
[(divide) (ins #\/)]
|
|
[(add) (ins #\+)]
|
|
[(subtract) (ins #\-)]
|
|
[(decimal) (ins #\.)]
|
|
[(#\u3) (ins #\return)] ; NUMPAD-ENTER
|
|
[(#\return #\tab) (ins code)]
|
|
[else
|
|
(let ([vcode (if (char? code)
|
|
(char->integer code)
|
|
0)])
|
|
(when (and (vcode . >= . 32)
|
|
(or (vcode . <= . #xd800)
|
|
(vcode . > . #xdf00)))
|
|
(ins code)))]))))
|
|
|
|
(def/override (own-caret [any? ownit?])
|
|
(when (do-own-caret (and ownit? #t))
|
|
(need-caret-refresh)
|
|
(on-focus (and ownit? #t))))
|
|
|
|
(def/override (blink-caret)
|
|
(if s-caret-snip
|
|
(when s-admin
|
|
(let-boxes ([dx 0.0]
|
|
[dy 0.0]
|
|
[dc #f])
|
|
(set-box! dc (send s-admin get-dc dx dy))
|
|
(when dc
|
|
(let-boxes ([x 0.0] [y 0.0])
|
|
(get-snip-location s-caret-snip x y)
|
|
(send s-caret-snip blink-caret dc (- x dx) (- y dy))))))
|
|
(if (too-busy-to-refresh?)
|
|
;; we're busy; go away
|
|
(void)
|
|
(when (and (= endpos startpos)
|
|
(not flash?)
|
|
hilite-on?)
|
|
(set! caret-blinked? (not caret-blinked?))
|
|
(need-caret-refresh)))))
|
|
|
|
(def/override (size-cache-invalid)
|
|
(set! graphic-maybe-invalid? #t)
|
|
(set! graphics-invalid? #t)
|
|
(when (max-width . > . 0.0)
|
|
(set! flow-invalid? #t))
|
|
(set! snip-cache-invalid? #t))
|
|
|
|
(def/override-final (locked-for-read?)
|
|
read-locked?)
|
|
(def/override-final (locked-for-flow?)
|
|
flow-locked?)
|
|
(def/override-final (locked-for-write?)
|
|
write-locked?)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (can-insert? [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
#t)
|
|
(def/public (on-insert [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
(void))
|
|
(def/public (after-insert [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
(void))
|
|
|
|
(def/public (can-delete? [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
#t)
|
|
(def/public (on-delete [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
(void))
|
|
(def/public (after-delete [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
(void))
|
|
|
|
(def/public (can-change-style? [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
#t)
|
|
(def/public (on-change-style [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
(void))
|
|
(def/public (after-change-style [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? len])
|
|
(void))
|
|
|
|
(def/public (after-set-position) (void))
|
|
|
|
(def/public (can-set-size-constraint?) #t)
|
|
(def/public (on-set-size-constraint) (void))
|
|
(def/public (after-set-size-constraint) (void))
|
|
|
|
(def/public (after-split-snip [exact-nonnegative-integer? pos]) (void))
|
|
(def/public (after-merge-snips [exact-nonnegative-integer? pos]) (void))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/override (begin-edit-sequence [any? [undoable? #t]] [any? [interrupt-seqs? #t]])
|
|
(wait-sequence-lock)
|
|
|
|
(when (and (zero? delay-refresh)
|
|
(not interrupt-seqs?))
|
|
(push-streaks))
|
|
|
|
(end-streaks '(delayed))
|
|
|
|
(when (or (positive? s-noundomode)
|
|
(not undoable?))
|
|
(set! s-noundomode (add1 s-noundomode)))
|
|
|
|
(if (zero? delay-refresh)
|
|
(begin
|
|
(when ALLOW-X-STYLE-SELECTION?
|
|
(set! need-x-copy? #t))
|
|
(set! delay-refresh 1)
|
|
(on-edit-sequence))
|
|
(set! delay-refresh (add1 delay-refresh))))
|
|
|
|
(def/override (end-edit-sequence)
|
|
(if (zero? delay-refresh)
|
|
(log-error "end-edit-sequence without begin-edit-sequence")
|
|
(begin
|
|
(set! delay-refresh (sub1 delay-refresh))
|
|
(when (zero? delay-refresh)
|
|
(end-streaks null)
|
|
(pop-streaks)
|
|
(redraw)
|
|
(when ALLOW-X-STYLE-SELECTION?
|
|
(set! need-x-copy? #f))
|
|
(after-edit-sequence))
|
|
(when (positive? s-noundomode)
|
|
(set! s-noundomode (sub1 s-noundomode)))
|
|
(when (and (zero? delay-refresh)
|
|
s-need-on-display-size?)
|
|
(set! s-need-on-display-size? #f)
|
|
(on-display-size)))))
|
|
|
|
(def/override (refresh-delayed?)
|
|
(or (delay-refresh . > . 0)
|
|
(not s-admin)
|
|
(send s-admin refresh-delayed?)))
|
|
|
|
(def/override-final (in-edit-sequence?)
|
|
(delay-refresh . > . 0))
|
|
|
|
(def/override (locations-computed?)
|
|
(not graphic-maybe-invalid?))
|
|
|
|
(def/public (recalculate) (void))
|
|
|
|
(def/public (get-position [maybe-box? start] [maybe-box? [end #f]])
|
|
(when start (set-box! start startpos))
|
|
(when end (set-box! end endpos)))
|
|
|
|
(def/public (get-start-position) startpos)
|
|
(def/public (get-end-position) endpos)
|
|
|
|
(def/public (set-position [exact-nonnegative-integer? start]
|
|
[(make-alts exact-nonnegative-integer? (make-literal 'same)) [end 'same]]
|
|
[any? [ateol? #f]]
|
|
[any? [scroll? #t]]
|
|
[(symbol-in default x local) [seltype 'default]])
|
|
(do-set-position #f 'none start end ateol? scroll? seltype))
|
|
|
|
(def/public (set-position-bias-scroll [symbol? bias]
|
|
[exact-nonnegative-integer? start]
|
|
[(make-alts exact-nonnegative-integer? (make-literal 'same)) [end 'same]]
|
|
[any? [ateol? #f]]
|
|
[any? [scroll? #t]]
|
|
[(symbol-in default x local) [seltype 'default]])
|
|
(do-set-position #f bias start end ateol? scroll? seltype))
|
|
|
|
(define/private (do-set-position setflash? bias start end ateol? scroll? seltype)
|
|
(unless flow-locked?
|
|
(when (and (not setflash?)
|
|
(or (not flash?) (not flashautoreset?) (not flashdirectoff?)))
|
|
(end-streaks '(delayed)))
|
|
|
|
(unless (or (start . < . 0)
|
|
(and (number? end)
|
|
(start . > . end)))
|
|
(let* ([start (min start len)]
|
|
[end (if (symbol? end)
|
|
start
|
|
(min end len))]
|
|
[ateol?
|
|
(and ateol?
|
|
(= end start)
|
|
(let-values ([(snip s-pos)
|
|
(find-snip/pos start 'before)])
|
|
(and (has-flag? (snip->flags snip) NEWLINE)
|
|
(not (has-flag? (snip->flags snip) INVISIBLE))
|
|
(= start (+ s-pos (snip->count snip))))))])
|
|
(let-values ([(oldstart oldend oldateol?)
|
|
(if flash?
|
|
(values flashstartpos flashendpos flashposateol?)
|
|
(values startpos endpos posateol?))])
|
|
(when (and (not setflash?)
|
|
flash?
|
|
flashautoreset?)
|
|
(set! flash? #f)
|
|
(when flash-timer
|
|
(send flash-timer stop)
|
|
(set! flash-timer #f)))
|
|
(let* ([need-refresh? (not (and (= oldstart start)
|
|
(= oldend end)
|
|
(eq? oldateol? ateol?)))]
|
|
[changed-pos? need-refresh?])
|
|
|
|
(if setflash?
|
|
(begin
|
|
(set! flashstartpos start)
|
|
(set! flashendpos end)
|
|
(set! flashposateol? ateol?))
|
|
(begin
|
|
(when ALLOW-X-STYLE-SELECTION?
|
|
(when (or (= end start)
|
|
(not (eq? editor-x-selection-allowed this))
|
|
(eq? 'local seltype))
|
|
(when (or (zero? delay-refresh) need-x-copy?)
|
|
(set! need-x-copy? #f)
|
|
(copy-out-x-selection))))
|
|
|
|
(check-merge-snips startpos)
|
|
(check-merge-snips endpos)
|
|
|
|
(set! caret-style #f)
|
|
(set! startpos start)
|
|
(set! endpos end)
|
|
(set! posateol? ateol?)))
|
|
|
|
(let-values ([(need-refresh? need-full-refresh?)
|
|
(let ([refresh? (and ALLOW-X-STYLE-SELECTION?
|
|
(not setflash?)
|
|
editor-x-selection-mode?
|
|
(or (and (not (eq? 'local seltype))
|
|
(not (= start end ))
|
|
(not (eq? editor-x-selection-owner this))
|
|
(eq? (own-x-selection #t #f seltype) 'x))
|
|
(and (or (= start end)
|
|
(not (eq? editor-x-selection-allowed this))
|
|
(eq? 'local seltype))
|
|
(eq? editor-x-selection-owner this)
|
|
(own-x-selection #f #f #f))))])
|
|
(values (or refresh? need-refresh?)
|
|
refresh?))])
|
|
(when setflash?
|
|
(set! flash? #t))
|
|
|
|
(let ([need-refresh?
|
|
(or
|
|
(and scroll?
|
|
(let-values ([(scroll-start scroll-end bias)
|
|
(cond
|
|
[(eq? bias 'start-only)
|
|
(values start start 'none)]
|
|
[(eq? bias 'end-only)
|
|
(values end end 'none)]
|
|
[else
|
|
(values start end bias)])])
|
|
(let ([was-blinked? caret-blinked?])
|
|
(set! caret-blinked? #f)
|
|
(if (scroll-to-position/refresh scroll-start posateol? #t scroll-end bias)
|
|
#t
|
|
(begin
|
|
(set! caret-blinked? was-blinked?)
|
|
#f)))))
|
|
need-refresh?)])
|
|
|
|
(when need-refresh?
|
|
(set! caret-blinked? #f)
|
|
(if (or (start . >= . oldend)
|
|
(end . <= . oldstart)
|
|
need-full-refresh?)
|
|
(begin
|
|
;; no overlap:
|
|
(need-refresh oldstart oldend)
|
|
(need-refresh start end))
|
|
(begin
|
|
(when (start . < . oldstart)
|
|
(need-refresh start oldstart))
|
|
(when (oldstart . < . start)
|
|
(need-refresh oldstart start))
|
|
(when (end . < . oldend)
|
|
(need-refresh end oldend))
|
|
(when (oldend . < . end)
|
|
(need-refresh oldend end)))))))
|
|
|
|
(when (and changed-pos? (not setflash?))
|
|
(after-set-position))))))))
|
|
|
|
(define/private (scroll-to-position/refresh start
|
|
[ateol? #f]
|
|
[refresh? #t]
|
|
[end 'same]
|
|
[bias 'none])
|
|
(and
|
|
(not flow-locked?)
|
|
(let ([end (if (eq? end 'same) start (max start end))])
|
|
(cond
|
|
[(positive? delay-refresh)
|
|
(when s-admin
|
|
(set! delayedscrollbox? #f)
|
|
(set! delayedscroll start)
|
|
(set! delayedscrollend end)
|
|
(set! delayedscrollateol? ateol?)
|
|
(set! delayedscrollbias bias))
|
|
#f]
|
|
[(not (check-recalc #t #f))
|
|
#f]
|
|
[else
|
|
(set! delayedscroll -1)
|
|
|
|
(let-boxes ([topx 0.0] [topy 0.0]
|
|
[botx 0.0] [boty 0.0])
|
|
(begin
|
|
(position-location start topx topy #t ateol? #t)
|
|
(position-location end botx boty #f ateol? #t))
|
|
(let-values ([(topx botx)
|
|
(if (botx . < . topx)
|
|
;; when the end position is to the left of the start position
|
|
(values 0 total-width)
|
|
(values topx botx))])
|
|
(scroll-editor-to topx topy (- botx topx) (- boty topy) refresh? bias)))]))))
|
|
|
|
(def/public (scroll-to-position [exact-nonnegative-integer? start]
|
|
[any? [ateol? #f]]
|
|
[(make-alts exact-nonnegative-integer? (make-literal 'same)) [end 'same]]
|
|
[(symbol-in start end none) [bias 'none]])
|
|
(scroll-to-position/refresh start ateol? #t end bias))
|
|
|
|
(define/private (get-visible-X-range start end all? find)
|
|
(when (check-recalc #t #f)
|
|
(let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0])
|
|
(if all?
|
|
(send s-admin get-max-view x y w h)
|
|
(send s-admin get-view x y w h))
|
|
(begin
|
|
(when start
|
|
(set-box! start (find x y)))
|
|
(when end
|
|
(set-box! end (find (+ x w) (+ y h))))))))
|
|
|
|
(def/public (get-visible-position-range [maybe-box? start] [maybe-box? end] [any? [all? #t]])
|
|
(get-visible-X-range start end all? (lambda (x y) (find-position x y))))
|
|
|
|
(def/public (get-visible-line-range [maybe-box? start] [maybe-box? end] [any? [all? #t]])
|
|
(get-visible-X-range start end all? (lambda (x y) (find-line y))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (move-position [(make-alts symbol? char?) code]
|
|
[any? [extend-selection? #f]]
|
|
[(symbol-in simple word page line) [kind 'simple]])
|
|
(unless (or flow-locked?
|
|
(not (check-recalc (max-width . > . 0.0) #f #t)))
|
|
|
|
(let-values ([(anchor?) anchor-streak?]
|
|
[(vcursor?) vcursor-streak?]
|
|
[(extendstart extendend)
|
|
(if (or extend-streak? anchor-streak?)
|
|
(values extendstartpos extendendpos)
|
|
(values startpos endpos))]
|
|
[(kas?) keep-anchor-streak?])
|
|
|
|
(set! keep-anchor-streak? anchor-streak?)
|
|
|
|
(end-streaks '(delayed))
|
|
|
|
(let* ([extend? (or anchor? extend-selection?)]
|
|
;; rightshrink: motion to right shrinks the selected region
|
|
[rightshrink? (and extend? (startpos . < . extendstart))]
|
|
[leftshrink? (and extend? (endpos . > . extendend))])
|
|
(let-values ([(code kind)
|
|
(cond
|
|
[(eq? 'prior code) (values 'up 'page)]
|
|
[(eq? 'next code) (values 'down 'page)]
|
|
[else (values code kind)])])
|
|
(cond
|
|
[(eq? 'home code)
|
|
(if leftshrink?
|
|
(set-position-bias-scroll 'start-only extendstart extendend)
|
|
(set-position-bias-scroll 'start-only 0 (if extend? extendend 0)))]
|
|
[(eq? 'end code)
|
|
(if rightshrink?
|
|
(set-position-bias-scroll 'end-only extendstart extendend)
|
|
(set-position-bias-scroll 'end-only (if extend? extendstart len) len))]
|
|
[(eq? 'left code)
|
|
(if (and (not (eq? 'line kind))
|
|
(not (eq? 'word kind))
|
|
(not extend?)
|
|
(not (= endpos startpos)))
|
|
(set-position startpos)
|
|
(begin
|
|
;; pick a starting place
|
|
(let ([start
|
|
(let ([start (if leftshrink?
|
|
endpos
|
|
startpos)])
|
|
(cond
|
|
[(eq? 'word kind)
|
|
(let-boxes ([start start])
|
|
(find-wordbreak start #f 'caret)
|
|
start)]
|
|
[(eq? 'line kind)
|
|
(line-start-position (position-line start posateol?))]
|
|
[else (max 0 (sub1 start))]))])
|
|
(let-values ([(start end)
|
|
(if extend?
|
|
(if leftshrink?
|
|
(let ([start (max start extendend)]) ;; collapse to original
|
|
(values startpos start))
|
|
(values start endpos))
|
|
(values start start))])
|
|
(set-position-bias-scroll 'start-only start end)))))]
|
|
[(eq? 'right code)
|
|
(if (and (not (eq? 'line kind))
|
|
(not (eq? 'word kind))
|
|
(not extend?)
|
|
(not (= endpos startpos)))
|
|
(set-position endpos endpos #t)
|
|
(begin
|
|
;; pick a starting place
|
|
(let ([end
|
|
(let ([end (if rightshrink?
|
|
startpos
|
|
endpos)])
|
|
(cond
|
|
[(eq? 'word kind)
|
|
(let-boxes ([end end])
|
|
(find-wordbreak #f end 'caret)
|
|
end)]
|
|
[(eq? 'line kind)
|
|
(line-end-position (position-line end posateol?))]
|
|
[else (add1 end)]))])
|
|
(let-values ([(start end)
|
|
(if extend?
|
|
(if rightshrink?
|
|
(let ([end (min end extendstart)]) ;; collapse to original
|
|
(values end endpos))
|
|
(values startpos end))
|
|
(values end end))])
|
|
(set-position-bias-scroll 'end-only start end #t)))))]
|
|
[(or (eq? 'up code) (eq? 'down code))
|
|
(let ([special-scroll? (eq? 'page kind)]) ;; used when paging
|
|
(let-values ([(start end ateol? special-scroll?
|
|
scroll-left scroll-top scroll-width scroll-height
|
|
bias)
|
|
(if (eq? 'up code)
|
|
(let ([start (if leftshrink?
|
|
endpos
|
|
startpos)])
|
|
(let-boxes ([vcl vcursorloc])
|
|
(when (not vcursor?)
|
|
(position-location start vcl #f #t posateol? #t))
|
|
(set! vcursorloc vcl)
|
|
(let ([cline (position-line start posateol?)])
|
|
(let-values ([(i scroll-left scroll-top scroll-width scroll-height)
|
|
(if (eq? 'page kind)
|
|
;; the current top line should become the next-to bottom line.
|
|
;; the caret should go to line above current top line, but
|
|
;; watch out for:
|
|
;; - especially tall lines
|
|
;; - already at top
|
|
(let-boxes ([scroll-left 0.0] [vy 0.0]
|
|
[scroll-width 0.0] [scroll-height 0.0])
|
|
(when s-admin
|
|
(send s-admin get-view scroll-left vy scroll-width scroll-height))
|
|
;; top line should be completely visible as bottom line after
|
|
;; scrolling
|
|
(let* ([top (find-scroll-line vy)]
|
|
[ty (scroll-line-location (+ top 1))]
|
|
[newtop (find-scroll-line (- ty scroll-height))]
|
|
[y (scroll-line-location newtop)]
|
|
[newtop (if (y . < . (- ty scroll-height))
|
|
(add1 newtop)
|
|
newtop)]
|
|
[y (scroll-line-location newtop)]
|
|
;; y is the new top location
|
|
[y (if (y . >= . vy)
|
|
;; no or backward progess
|
|
(scroll-line-location (max 0 (sub1 top)))
|
|
y)])
|
|
(let ([i (if (= vy y)
|
|
;; must be at the top:
|
|
(find-line y)
|
|
(let ([i (find-line (+ y scroll-height))])
|
|
(if ((line-location (max 0 (- i 1))) . > . y)
|
|
(sub1 i)
|
|
i)))])
|
|
(values i scroll-left y scroll-width scroll-height))))
|
|
(values (- cline 1) 0.0 0.0 0.0 0.0))])
|
|
(let-boxes ([start 0] [ateol? #f])
|
|
(if (i . >= . 0)
|
|
(set-box! start (find-position-in-line i vcursorloc ateol?))
|
|
(begin (set-box! start 0) (set-box! ateol? #f)))
|
|
(let-values ([(start end special-scroll?)
|
|
(if extend?
|
|
(if leftshrink?
|
|
(if (start . < . extendend)
|
|
(if (and (not (eq? 'page kind))
|
|
(start . < . extendstart))
|
|
;; inversion!
|
|
(values start extendend special-scroll?)
|
|
;; Collapse to original
|
|
(values startpos extendend #f))
|
|
(values startpos start special-scroll?))
|
|
(values start endpos special-scroll?))
|
|
(values start start special-scroll?))])
|
|
(values start end ateol? special-scroll?
|
|
scroll-left scroll-top scroll-width scroll-height
|
|
(if leftshrink? 'end-only 'start-only))))))))
|
|
;; (eq? code 'down)
|
|
(let ([end (if rightshrink?
|
|
startpos
|
|
endpos)])
|
|
(let-boxes ([vcl vcursorloc])
|
|
(when (not vcursor?)
|
|
(position-location end vcl #f #t posateol? #t))
|
|
(set! vcursorloc vcl)
|
|
(let ([cline (position-line end posateol?)])
|
|
(let-values ([(i scroll-left scroll-top scroll-width scroll-height)
|
|
(if (eq? 'page kind)
|
|
(let-boxes ([scroll-left 0.0] [vy 0.0]
|
|
[scroll-width 0.0] [scroll-height 0.0])
|
|
(when s-admin
|
|
(send s-admin get-view scroll-left vy scroll-width scroll-height))
|
|
;; last fully-visible line is the new top line
|
|
(let* ([newtop (find-scroll-line (+ vy scroll-height))]
|
|
[y (scroll-line-location (+ newtop 1))]
|
|
[newtop (if (y . > . (+ vy scroll-height))
|
|
(sub1 newtop)
|
|
newtop)]
|
|
[y (scroll-line-location newtop)])
|
|
;; y is the new top location
|
|
(let-values ([(newtop y)
|
|
(if (y . <= . vy)
|
|
;; no or backwards movement; scroll back one
|
|
(let ([newtop (+ (find-scroll-line vy) 1)])
|
|
(values newtop (scroll-line-location newtop)))
|
|
(values newtop y))])
|
|
;; compute top line, for caret
|
|
(let* ([i (find-line y)]
|
|
[i (if ((line-location i #t) . < . y)
|
|
(add1 i)
|
|
i)])
|
|
;; Now, suppose we're scrolling down while extending the
|
|
;; selection. We want to be able to see that we're
|
|
;; selecting. So try moving the line `i' down one more, if
|
|
;; there's room:
|
|
(let ([i (if ((line-location (+ i 1) #f) . < . (+ y scroll-height))
|
|
(add1 i)
|
|
i)])
|
|
(values i scroll-left (- y 1) scroll-width scroll-height))))))
|
|
(values (+ cline 1) 0.0 0.0 0.0 0.0))])
|
|
(let-values ([(end ateol?)
|
|
(if (i . <= . (sub1 num-valid-lines))
|
|
(let-boxes ([ateol? #f] [end 0])
|
|
(set-box! end (find-position-in-line i vcursorloc ateol?))
|
|
(values end ateol?))
|
|
(values len #f))])
|
|
(let-values ([(start end special-scroll?)
|
|
(if extend?
|
|
(if rightshrink?
|
|
(if (end . > . extendstart)
|
|
(if (and (not (eq? 'page kind))
|
|
(end . > . extendend))
|
|
;; inversion!
|
|
(values extendstart end special-scroll?)
|
|
;; collapse to original
|
|
(values extendstart endpos #f))
|
|
(values end endpos special-scroll?))
|
|
(values startpos end special-scroll?))
|
|
(values end end special-scroll?))])
|
|
(values start end ateol? special-scroll?
|
|
scroll-left scroll-top scroll-width scroll-height
|
|
(if rightshrink? 'start-only 'end-only)))))))))])
|
|
(when special-scroll?
|
|
(begin-edit-sequence))
|
|
|
|
;; scroll only if !special-scroll
|
|
(set-position-bias-scroll bias start end ateol? (not special-scroll?))
|
|
|
|
(when special-scroll?
|
|
;; special scrolling intructions:
|
|
(do-scroll-to #f scroll-left scroll-top scroll-width scroll-height #f 'none)
|
|
|
|
(end-edit-sequence))
|
|
|
|
(set! vcursor-streak? #t)))])
|
|
|
|
(set! keep-anchor-streak? kas?)
|
|
(when extend?
|
|
(set! extend-streak? #t))
|
|
|
|
(when (or extend-streak? anchor-streak?)
|
|
(set! extendendpos extendend)
|
|
(set! extendstartpos extendstart)))))))
|
|
|
|
(def/public (set-anchor [any? on?])
|
|
(let ([wason? anchor-streak?])
|
|
(set! anchor-streak? (and on? #t))
|
|
(when (and on? (not wason?))
|
|
(set! extendendpos endpos)
|
|
(set! extendstartpos startpos))))
|
|
|
|
(def/public (get-anchor)
|
|
anchor-streak?)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (do-insert isnip str snipsl start end scroll-ok?)
|
|
(assert (consistent-snip-lines 'do-insert))
|
|
(unless (or write-locked?
|
|
s-user-locked?
|
|
(start . < . 0))
|
|
(let ([start (min start len)]
|
|
[str (and str (positive? (string-length str)) str)])
|
|
;; turn off pending style, if it doesn't apply
|
|
(when caret-style
|
|
(when (or (not (equal? end start)) (not (= startpos start)))
|
|
(set! caret-style #f)))
|
|
(let ([deleted? (and (not (eq? end 'same))
|
|
(start . < . end)
|
|
(begin
|
|
(when ALLOW-X-STYLE-SELECTION?
|
|
(when (zero? delay-refresh)
|
|
(set! need-x-copy? #t)))
|
|
(when (or isnip str snipsl)
|
|
(begin-edit-sequence))
|
|
(delete start end scroll-ok?)
|
|
(when ALLOW-X-STYLE-SELECTION?
|
|
(when (zero? delay-refresh)
|
|
(set! need-x-copy? #f)))
|
|
#t))])
|
|
(when (or isnip str snipsl)
|
|
(set! write-locked? #t)
|
|
(let ([success-finish
|
|
(lambda (addlen inserted-line?)
|
|
(set! initial-style-needed? #f)
|
|
(set! revision-count (add1 revision-count))
|
|
|
|
(adjust-clickbacks start start addlen #f)
|
|
|
|
(unless s-modified?
|
|
(add-undo-rec (make-object unmodify-record% delayed-streak?)))
|
|
(unless (positive? s-noundomode)
|
|
(add-undo-rec
|
|
(make-object insert-record%
|
|
start addlen
|
|
(or deleted? typing-streak? delayed-streak?
|
|
insert-force-streak?
|
|
(not s-modified?))
|
|
startpos endpos)))
|
|
(when (positive? delay-refresh)
|
|
(set! delayed-streak? #t))
|
|
|
|
(let ([scroll? (= start startpos)])
|
|
|
|
(when (startpos . >= . start)
|
|
(set! startpos (+ startpos addlen)))
|
|
(when (endpos . >= . start)
|
|
(set! endpos (+ endpos addlen)))
|
|
(unless refresh-unset?
|
|
(when (refresh-start . >= . start)
|
|
(set! refresh-start (+ refresh-start addlen)))
|
|
(when (refresh-end . >= . start)
|
|
(set! refresh-end (+ refresh-end addlen))))
|
|
|
|
(set! extra-line? (has-flag? (snip->flags last-snip) NEWLINE))
|
|
|
|
(set! write-locked? #f)
|
|
(set! flow-locked? #f)
|
|
|
|
(when scroll?
|
|
(set! caret-blinked? #f))
|
|
|
|
(when (and scroll? scroll-ok?)
|
|
(set! delay-refresh (add1 delay-refresh))
|
|
(scroll-to-position/refresh startpos)
|
|
(set! delay-refresh (sub1 delay-refresh)))
|
|
|
|
(set! changed? #t)
|
|
|
|
(set! caret-style #f)
|
|
|
|
(if inserted-line?
|
|
(begin
|
|
(set! graphic-maybe-invalid? #t)
|
|
(need-refresh start))
|
|
(refresh-by-line-demand))
|
|
|
|
(when deleted?
|
|
(end-edit-sequence))
|
|
|
|
(unless s-modified?
|
|
(set-modified #t))
|
|
|
|
(assert (consistent-snip-lines 'pre-after-insert))
|
|
|
|
(after-insert start addlen)))]
|
|
[fail-finish
|
|
(lambda ()
|
|
(set! write-locked? #f)
|
|
(set! flow-locked? #f)
|
|
(when deleted?
|
|
(end-edit-sequence)))])
|
|
(cond
|
|
[(or isnip snipsl)
|
|
(insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)]
|
|
[else (insert-string str start success-finish fail-finish)])))))
|
|
(assert (consistent-snip-lines 'post-do-insert))))
|
|
|
|
(define/private (insert-snips snipsl start success-finish fail-finish)
|
|
(let ([addlen (for/fold ([addlen 0])
|
|
([isnip (in-list snipsl)]
|
|
#:when addlen)
|
|
(let ([c (snip->count isnip)])
|
|
(and (positive? c)
|
|
(not (send isnip is-owned?))
|
|
(+ addlen c))))])
|
|
|
|
(if (or (not addlen)
|
|
(zero? addlen)
|
|
(not (can-insert? start addlen)))
|
|
(fail-finish)
|
|
(begin
|
|
(on-insert start addlen)
|
|
|
|
(set! flow-locked? #t)
|
|
|
|
;; make sure on-insert didn't do something bad to the snips:
|
|
(if (not (for/and ([isnip (in-list snipsl)])
|
|
(and (positive? (snip->count isnip))
|
|
(not (send isnip is-owned?)))))
|
|
|
|
(fail-finish)
|
|
|
|
(let loop ([did-one? #f]
|
|
[before-snip #f]
|
|
[inserted-line? #f]
|
|
[snipsl snipsl])
|
|
|
|
(if (null? snipsl)
|
|
(success-finish addlen inserted-line?)
|
|
(let ([isnip (car snipsl)])
|
|
(when (and (has-flag? (snip->flags isnip) NEWLINE)
|
|
(not (has-flag? (snip->flags isnip) HARD-NEWLINE)))
|
|
(set-snip-flags! isnip (remove-flag (snip->flags isnip) NEWLINE)))
|
|
|
|
(assert (consistent-snip-lines 'inner-insert))
|
|
|
|
|
|
(let-values ([(before-snip inserted-new-line?)
|
|
(if (and (zero? len) (not did-one?))
|
|
|
|
;; special case: ignore the empty snip
|
|
(begin
|
|
(set! snips isnip)
|
|
(set! last-snip isnip)
|
|
(let ([line-root (create-mline)])
|
|
(set-box! line-root-box line-root)
|
|
(set-snip-line! isnip line-root)
|
|
(set-mline-snip! line-root isnip)
|
|
(set-mline-last-snip! line-root isnip)
|
|
(when (max-width . > . 0)
|
|
(mline-mark-check-flow line-root)))
|
|
(values before-snip #f))
|
|
|
|
(let* ([gsnip (if (not did-one?)
|
|
(begin
|
|
(make-snipset start start)
|
|
(do-find-snip start 'after-or-none))
|
|
before-snip)]
|
|
[before-snip (or before-snip gsnip)]
|
|
[inserted-new-line?
|
|
(if (not gsnip)
|
|
(begin
|
|
(append-snip isnip)
|
|
(let ([gsnip (mline-last-snip last-line)])
|
|
(if (and gsnip (has-flag? (snip->flags gsnip) HARD-NEWLINE))
|
|
(let ([line (mline-insert last-line line-root-box #f)])
|
|
(set-snip-line! isnip line)
|
|
(set-mline-snip! line isnip)
|
|
(set-mline-last-snip! line isnip)
|
|
(set! num-valid-lines (add1 num-valid-lines))
|
|
#t)
|
|
(begin
|
|
;; The former last snip might still have a NEWLINE
|
|
;; flag due to line-flowing
|
|
(when (has-flag? (snip->flags gsnip) NEWLINE)
|
|
(set-snip-flags! gsnip (remove-flag (snip->flags gsnip) NEWLINE)))
|
|
(set-snip-line! isnip last-line)
|
|
(when (not (mline-snip last-line))
|
|
(set-mline-snip! last-line isnip))
|
|
(set-mline-last-snip! last-line isnip)
|
|
;; maybe added extra ghost line:
|
|
(has-flag? (snip->flags isnip) HARD-NEWLINE)))))
|
|
(begin
|
|
(insert-snip gsnip isnip)
|
|
(if (has-flag? (snip->flags isnip) HARD-NEWLINE)
|
|
(let* ([gline (snip->line gsnip)]
|
|
[line (mline-insert gline line-root-box #t)])
|
|
(set-snip-line! isnip line)
|
|
(set! num-valid-lines (add1 num-valid-lines))
|
|
(if (eq? gsnip (mline-snip gline))
|
|
(set-mline-snip! line isnip)
|
|
(set-mline-snip! line (mline-snip gline)))
|
|
(set-mline-last-snip! line isnip)
|
|
(set-mline-snip! gline gsnip)
|
|
|
|
(let loop ([c-snip (mline-snip line)])
|
|
(unless (eq? c-snip isnip)
|
|
(set-snip-line! c-snip line)
|
|
(loop (snip->next c-snip))))
|
|
|
|
(mline-calc-line-length gline)
|
|
(mline-mark-recalculate gline)
|
|
#t)
|
|
(let ([gline (snip->line gsnip)])
|
|
(set-snip-line! isnip gline)
|
|
(when (eq? (mline-snip gline) gsnip)
|
|
(set-mline-snip! gline isnip))
|
|
#f))))])
|
|
|
|
(when (max-width . > . 0)
|
|
(mline-mark-check-flow (snip->line isnip))
|
|
(let ([prev (snip->prev isnip)])
|
|
(when (and prev
|
|
(not (has-flag? (snip->flags isnip) NEWLINE)))
|
|
(mline-mark-check-flow (snip->line prev))))
|
|
(let ([next (mline-next (snip->line isnip))])
|
|
(when (and next
|
|
(has-flag? (snip->flags isnip) HARD-NEWLINE))
|
|
(mline-mark-check-flow next))))
|
|
|
|
(values before-snip inserted-new-line?)))])
|
|
|
|
(set-snip-style! isnip (send s-style-list convert (or (snip->style isnip)
|
|
(send s-style-list basic-style))))
|
|
|
|
(send isnip size-cache-invalid)
|
|
|
|
(mline-calc-line-length (snip->line isnip))
|
|
(mline-mark-recalculate (snip->line isnip))
|
|
|
|
(set! len (+ len (snip->count isnip)))
|
|
|
|
(snip-set-admin isnip snip-admin)
|
|
|
|
(set! first-line (mline-first (unbox line-root-box)))
|
|
(set! last-line (mline-last (unbox line-root-box)))
|
|
|
|
(assert (consistent-snip-lines 'inner-insert2))
|
|
|
|
(loop #t
|
|
before-snip
|
|
(or inserted-line? inserted-new-line?)
|
|
(cdr snipsl)))))))))))
|
|
|
|
(define/private (insert-string str start success-finish fail-finish)
|
|
(let ([addlen (string-length str)])
|
|
(if (not (can-insert? start addlen))
|
|
(fail-finish)
|
|
(begin
|
|
(on-insert start addlen)
|
|
|
|
(set! flow-locked? #t)
|
|
|
|
(let-values ([(snip s-pos inserted-line?)
|
|
(if (zero? len)
|
|
|
|
(let* ([style (if (and sticky-styles?
|
|
(not initial-style-needed?))
|
|
(snip->style snips)
|
|
(get-default-style))]
|
|
[snip (insert-text-snip start style)])
|
|
(set! caret-style #f)
|
|
(set-mline-snip! (unbox line-root-box) snip)
|
|
(set-mline-last-snip! (unbox line-root-box) snip)
|
|
(values snip 0 #f))
|
|
|
|
(let-values ([(gsnip s-pos)
|
|
(if (positive? start)
|
|
(find-snip/pos start 'before)
|
|
(values #f 0))])
|
|
(let-values ([(snip s-pos)
|
|
(if (or (not gsnip)
|
|
(and caret-style (not (eq? caret-style (snip->style gsnip))))
|
|
(not (has-flag? (snip->flags gsnip) IS-TEXT))
|
|
((+ (snip->count gsnip) addlen) . > . MAX-COUNT-FOR-SNIP)
|
|
(and (not sticky-styles?)
|
|
(not (eq? (snip->style gsnip) (get-default-style)))))
|
|
|
|
(let ([style (or caret-style
|
|
(if sticky-styles?
|
|
(if gsnip
|
|
(snip->style gsnip)
|
|
(snip->style snips))
|
|
(get-default-style)))])
|
|
(let ([snip (insert-text-snip start style)])
|
|
(set! caret-style #f)
|
|
(values snip start)))
|
|
|
|
(let ([snip gsnip])
|
|
(if (has-flag? (snip->flags snip) CAN-APPEND)
|
|
(values snip s-pos)
|
|
(let ([style (if sticky-styles?
|
|
(snip->style snip)
|
|
(get-default-style))])
|
|
(values (insert-text-snip start style)
|
|
start)))))])
|
|
|
|
(if (and gsnip
|
|
(has-flag? (snip->flags gsnip) HARD-NEWLINE)
|
|
(eq? (snip->next gsnip) snip))
|
|
;; preceding snip was a newline, so the new slip belongs on the next line:
|
|
(let* ([oldline (snip->line gsnip)]
|
|
[inserted-new-line?
|
|
(if (mline-next oldline)
|
|
#f
|
|
(begin
|
|
(mline-insert oldline line-root-box #f)
|
|
(set! num-valid-lines (add1 num-valid-lines))
|
|
(set-mline-last-snip! (mline-next oldline) snip)
|
|
#t))])
|
|
(let ([newline (mline-next oldline)])
|
|
(set-snip-line! snip newline)
|
|
|
|
(set-mline-last-snip! oldline gsnip)
|
|
(set-mline-snip! newline snip)
|
|
|
|
(mline-calc-line-length oldline)
|
|
(mline-mark-recalculate oldline)
|
|
(values snip s-pos inserted-new-line?)))
|
|
|
|
(values snip s-pos #f)))))])
|
|
|
|
(let ([s (- start s-pos)])
|
|
(set-snip-flags! snip (add-flag (snip->flags snip) CAN-SPLIT))
|
|
(send snip insert str addlen s)
|
|
(when (has-flag? (snip->flags snip) CAN-SPLIT)
|
|
(set-snip-flags! snip (remove-flag (snip->flags snip) CAN-SPLIT)))
|
|
|
|
(mline-calc-line-length (snip->line snip))
|
|
(mline-mark-recalculate (snip->line snip))
|
|
|
|
(when (max-width . > . 0)
|
|
(mline-mark-check-flow (snip->line snip))
|
|
(let ([prev (mline-prev (snip->line snip))])
|
|
(when (and prev
|
|
(not (has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE)))
|
|
(mline-mark-check-flow prev))))
|
|
|
|
;; The text is inserted, but all into one big snip. If the
|
|
;; inserted text contains any newlines or tabs, we need to split
|
|
;; it up to use tab snips or the HARD-NEWLINE flag:
|
|
(let loop ([snip-start-pos start]
|
|
[str (string-snip-buffer snip)]
|
|
[sp (+ s (string-snip-dtext snip))]
|
|
[i 0]
|
|
[cnt 0]
|
|
[inserted-line? inserted-line?])
|
|
(if (= i addlen)
|
|
(begin
|
|
(set! first-line (mline-first (unbox line-root-box)))
|
|
(set! last-line (mline-last (unbox line-root-box)))
|
|
(set! len (+ len addlen))
|
|
(assert (= (last-position) (+ (mline-get-position last-line)
|
|
(mline-len last-line))))
|
|
(success-finish addlen inserted-line?))
|
|
(begin
|
|
(when (equal? (string-ref str sp) #\return)
|
|
(string-set! str sp #\newline))
|
|
(let ([c (string-ref str sp)])
|
|
(cond
|
|
[(or (equal? c #\newline) (equal? c #\tab))
|
|
(let ([newline? (equal? c #\newline)])
|
|
(make-snipset (+ i start) (+ i start 1))
|
|
(let ([snip (do-find-snip (+ i start) 'after)])
|
|
(if newline?
|
|
|
|
;; forced return - split the snip
|
|
(begin
|
|
(set-snip-flags! snip
|
|
(remove-flag
|
|
(add-flag (add-flag (add-flag (snip->flags snip)
|
|
NEWLINE)
|
|
HARD-NEWLINE)
|
|
INVISIBLE)
|
|
CAN-APPEND))
|
|
(if (not (eq? snip (mline-last-snip (snip->line snip))))
|
|
(let* ([old-line (snip->line snip)]
|
|
[line (mline-insert old-line line-root-box #t)])
|
|
(set-snip-line! snip line)
|
|
(set! num-valid-lines (add1 num-valid-lines))
|
|
(set-mline-last-snip! line snip)
|
|
(set-mline-snip! line (mline-snip old-line))
|
|
|
|
;; retarget snips moved to new line:
|
|
(let loop ([c-snip (mline-snip old-line)])
|
|
(unless (eq? c-snip snip)
|
|
(set-snip-line! c-snip line)
|
|
(loop (snip->next c-snip))))
|
|
|
|
(set-mline-snip! old-line (snip->next snip))
|
|
|
|
(mline-calc-line-length old-line)
|
|
(mline-mark-recalculate old-line)
|
|
(when (max-width . > . 0)
|
|
(mline-mark-check-flow old-line))
|
|
|
|
(mline-calc-line-length line)
|
|
(mline-mark-recalculate line)
|
|
(when (max-width . > . 0)
|
|
(mline-mark-check-flow line)))
|
|
|
|
;; carriage-return inserted at the end of a auto-wrapped line;
|
|
;; line lengths stay the same, but next line now starts
|
|
;; a paragraph
|
|
(let ([next (mline-next (snip->line snip))])
|
|
(when next
|
|
(when (zero? (mline-starts-paragraph next))
|
|
(mline-set-starts-paragraph next #t))))))
|
|
|
|
;; convert a tab to a tab-snip%
|
|
(let ([tabsnip (let ([ts (on-new-tab-snip)])
|
|
(if (or (send ts is-owned?)
|
|
(positive? (snip->count ts)))
|
|
;; uh-oh
|
|
(new tab-snip%)
|
|
ts))])
|
|
(set-snip-style! tabsnip (snip->style snip))
|
|
(let* ([rsnip (snip-set-admin tabsnip snip-admin)]
|
|
[tabsnip (if (not (eq? rsnip tabsnip))
|
|
;; uh-oh
|
|
(let ([tabsnip (new tab-snip%)])
|
|
(set-snip-style! tabsnip (snip->style snip))
|
|
(send tabsnip set-admin snip-admin)
|
|
tabsnip)
|
|
tabsnip)])
|
|
|
|
(set-snip-flags! tabsnip
|
|
(add-flag (snip->flags tabsnip) CAN-SPLIT))
|
|
(send tabsnip insert "\t" 1 0)
|
|
(when (has-flag? (snip->flags tabsnip) CAN-SPLIT)
|
|
(set-snip-flags! tabsnip
|
|
(remove-flag (snip->flags tabsnip) CAN-SPLIT)))
|
|
(when (has-flag? (snip->flags snip) NEWLINE)
|
|
(set-snip-flags! tabsnip (add-flag (snip->flags tabsnip) NEWLINE)))
|
|
|
|
(splice-snip tabsnip (snip->prev snip) (snip->next snip))
|
|
(set-snip-line! tabsnip (snip->line snip))
|
|
(when (eq? (mline-snip (snip->line snip)) snip)
|
|
(set-mline-snip! (snip->line tabsnip) tabsnip))
|
|
(when (eq? (mline-last-snip (snip->line snip)) snip)
|
|
(set-mline-last-snip! (snip->line tabsnip) tabsnip))))))
|
|
|
|
(let ([snip (do-find-snip (+ i start 1) 'after)])
|
|
(let ([i (add1 i)])
|
|
(loop (+ i start)
|
|
(if (= i addlen) #f (string-snip-buffer snip))
|
|
(if (= i addlen) #f (string-snip-dtext snip))
|
|
i
|
|
0
|
|
(or inserted-line? newline?)))))]
|
|
|
|
[(cnt . > . MAX-COUNT-FOR-SNIP)
|
|
;; divide up snip, because it's too large:
|
|
(make-snipset (+ i start) (+ i start))
|
|
(let ([snip (do-find-snip (+ i start) 'after)])
|
|
(loop (+ i start)
|
|
(string-snip-buffer snip)
|
|
(add1 (string-snip-dtext snip))
|
|
(add1 i)
|
|
1
|
|
inserted-line?))]
|
|
|
|
[else
|
|
(loop start str (+ sp 1) (+ i 1) (+ cnt 1) inserted-line?)])))))))))))
|
|
|
|
(define/private (check-len str len)
|
|
(unless (len . <= . (string-length str))
|
|
(raise-mismatch-error (method-name 'text% 'insert)
|
|
(format "length ~e too large for given string: "
|
|
len)
|
|
str)))
|
|
|
|
(define/override (insert . args)
|
|
(case-args
|
|
args
|
|
[([string? str])
|
|
(do-insert #f str #f startpos endpos #t)]
|
|
[([string? str]
|
|
[exact-nonnegative-integer? start]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]]
|
|
[any? [scroll-ok? #t]])
|
|
(do-insert #f str #f start end scroll-ok?)]
|
|
[([exact-nonnegative-integer? len]
|
|
[string? str])
|
|
(check-len str len)
|
|
(do-insert #f (substring str 0 len) #f startpos endpos #t)]
|
|
[([exact-nonnegative-integer? len]
|
|
[string? str]
|
|
[exact-nonnegative-integer? start]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]]
|
|
[any? [scroll-ok? #t]])
|
|
(check-len str len)
|
|
(do-insert #f (substring str 0 len) #f start end scroll-ok?)]
|
|
[([snip% snip])
|
|
(do-insert snip #f #f startpos endpos #t)]
|
|
[([snip% snip]
|
|
[exact-nonnegative-integer? [start startpos]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]]
|
|
[any? [scroll-ok? #t]])
|
|
(do-insert snip #f #f start end scroll-ok?)]
|
|
[([char? ch])
|
|
(do-insert-char ch startpos endpos)]
|
|
[([char? ch]
|
|
[exact-nonnegative-integer? start]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]])
|
|
(do-insert-char ch start end)]
|
|
(method-name 'text% 'insert)))
|
|
|
|
(define/public (do-insert-snips snips pos)
|
|
(do-insert #f #f snips pos pos #t))
|
|
|
|
(define/private (do-insert-char ch start end)
|
|
(let ([streak? typing-streak?]
|
|
[ifs? insert-force-streak?])
|
|
(end-streaks '(delayed))
|
|
(set! insert-force-streak? streak?)
|
|
(do-insert #f (string ch) #f start end #t)
|
|
(set! insert-force-streak? ifs?)
|
|
(set! typing-streak? #t)))
|
|
|
|
(define/private (do-delete start end with-undo? [scroll-ok? #t])
|
|
(assert (consistent-snip-lines 'do-delete))
|
|
(unless (or write-locked? s-user-locked?)
|
|
(let-values ([(start end set-caret-style?)
|
|
(if (eq? end 'back)
|
|
(if (zero? start)
|
|
(values 0 0 #f)
|
|
(values (sub1 start) start #t))
|
|
(values start end (and (= start startpos)
|
|
(= end endpos))))])
|
|
(unless (or (start . >= . end)
|
|
(start . < . 0)
|
|
(start . >= . len))
|
|
(let ([end (min end len)])
|
|
(when ALLOW-X-STYLE-SELECTION?
|
|
(when (and (start . <= . startpos) (end . >= . endpos))
|
|
(when (or (zero? delay-refresh) need-x-copy?)
|
|
(set! need-x-copy? #f)
|
|
(copy-out-x-selection))))
|
|
|
|
(set! write-locked? #t)
|
|
|
|
(if (not (can-delete? start (- end start)))
|
|
(set! write-locked? #f)
|
|
(begin
|
|
(on-delete start (- end start))
|
|
|
|
(set! flow-locked? #t)
|
|
|
|
(make-snipset start end)
|
|
(set! revision-count (add1 revision-count))
|
|
|
|
(let* ([start-snip (do-find-snip start 'before-or-none)]
|
|
[end-snip (do-find-snip end 'before)]
|
|
[with-undo? (and with-undo?
|
|
(zero? s-noundomode))]
|
|
[rec (if with-undo?
|
|
(begin
|
|
(when (not s-modified?)
|
|
(add-undo-rec (make-object unmodify-record% delayed-streak?)))
|
|
(make-object delete-record%
|
|
start end
|
|
(or deletion-streak? delayed-streak?
|
|
delete-force-streak? (not s-modified?))
|
|
startpos endpos))
|
|
#f)])
|
|
|
|
(when (and set-caret-style? sticky-styles?)
|
|
(set! caret-style (if start-snip
|
|
(snip->style (snip->next start-snip))
|
|
(snip->style snips))))
|
|
|
|
(let-values ([(deleted-line? update-cursor?)
|
|
(let loop ([snip end-snip]
|
|
[deleted-line? #f]
|
|
[update-cursor? #f])
|
|
(if (eq? snip start-snip)
|
|
(values deleted-line? update-cursor?)
|
|
(let ([update-cursor?
|
|
(or (and (eq? snip s-caret-snip)
|
|
(let ([rl? read-locked?])
|
|
(set! read-locked? #t)
|
|
(send s-caret-snip own-caret #f)
|
|
(set! read-locked? rl?)
|
|
(set! s-caret-snip #f)
|
|
#t))
|
|
update-cursor?)])
|
|
|
|
(when with-undo?
|
|
(send rec insert-snip snip))
|
|
|
|
(let* ([prev (snip->prev snip)]
|
|
[deleted-another-line?
|
|
(let ([line (snip->line snip)])
|
|
(cond
|
|
[(eq? (mline-snip line) snip)
|
|
(if (eq? (mline-last-snip line) snip)
|
|
(begin
|
|
(mline-delete line line-root-box)
|
|
(set! num-valid-lines (sub1 num-valid-lines))
|
|
#t)
|
|
(begin
|
|
(set-mline-snip! line (snip->next snip))
|
|
#f))]
|
|
[(eq? (mline-last-snip line) snip)
|
|
(if (mline-next line)
|
|
(begin
|
|
(set-mline-last-snip! line (mline-last-snip (mline-next line)))
|
|
(mline-delete (mline-next line) line-root-box)
|
|
(set! num-valid-lines (sub1 num-valid-lines))
|
|
#t)
|
|
(begin
|
|
(set-mline-last-snip! line prev)
|
|
;; maybe deleted extra ghost line:
|
|
extra-line?))]
|
|
[else
|
|
#f]))])
|
|
(delete-snip snip)
|
|
(loop prev
|
|
(or deleted-line?
|
|
deleted-another-line?)
|
|
update-cursor?)))))])
|
|
|
|
(when (zero? snip-count)
|
|
(make-only-snip)
|
|
(when caret-style
|
|
(set-snip-style! snips caret-style)
|
|
(set! caret-style #f)))
|
|
|
|
(set! first-line (mline-first (unbox line-root-box)))
|
|
(set! last-line (mline-last (unbox line-root-box)))
|
|
|
|
(let-values ([(line moved-to-next?)
|
|
(if start-snip
|
|
(if (has-flag? (snip->flags start-snip) NEWLINE)
|
|
(if (mline-next (snip->line start-snip))
|
|
(values (mline-next (snip->line start-snip))
|
|
#t)
|
|
(begin
|
|
(mline-mark-check-flow (snip->line start-snip))
|
|
(values #f #f)))
|
|
(values (snip->line start-snip) #f))
|
|
(values first-line #f))])
|
|
|
|
(when line
|
|
;; fix line references from possibly moved snips:
|
|
(let ([next (snip->next (mline-last-snip line))])
|
|
(let loop ([snip (mline-snip line)])
|
|
(unless (eq? snip next)
|
|
(set-snip-line! snip line)
|
|
(loop (snip->next snip)))))
|
|
|
|
(mline-calc-line-length line)
|
|
(mline-mark-recalculate line)
|
|
|
|
(when (max-width . >= . 0)
|
|
(mline-mark-check-flow line)
|
|
(let ([next (mline-next line)])
|
|
(when next (mline-mark-check-flow next)))
|
|
(let ([prev (mline-prev line)])
|
|
(when (and prev
|
|
(has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE))
|
|
(mline-mark-check-flow prev)
|
|
(when (and moved-to-next?
|
|
deleted-line?
|
|
(mline-prev prev)
|
|
(not (has-flag? (snip->flags (mline-last-snip (mline-prev prev)))
|
|
HARD-NEWLINE)))
|
|
;; maybe the deleted object was in the middle of a long word,
|
|
;; and maybe now the long word can be folded into the previous
|
|
;; line
|
|
(mline-mark-check-flow (mline-prev prev)))))))
|
|
|
|
(adjust-clickbacks start end (- start end) rec)
|
|
|
|
(when with-undo?
|
|
(add-undo-rec rec)
|
|
(when (positive? delay-refresh)
|
|
(set! delayed-streak? #t)))
|
|
|
|
(let ([dellen (- end start)])
|
|
(set! len (- len dellen))
|
|
|
|
(check-merge-snips start)
|
|
|
|
(set! flow-locked? #f)
|
|
(set! write-locked? #f)
|
|
|
|
(cond
|
|
[(and (startpos . >= . start) (startpos . <= . end))
|
|
(set! caret-blinked? #f)
|
|
(set! startpos start)]
|
|
[(startpos . > . end)
|
|
(set! caret-blinked? #f)
|
|
(set! startpos (- startpos dellen))])
|
|
|
|
(cond
|
|
[(and (endpos . >= . start) (endpos . <= . end))
|
|
(set! endpos start)]
|
|
[(endpos . > . end)
|
|
(set! endpos (- endpos dellen))])
|
|
|
|
(unless refresh-unset?
|
|
(cond
|
|
[(and (refresh-start . >= . start) (refresh-start . <= . end))
|
|
(set! refresh-start start)]
|
|
[(refresh-start . >= . end)
|
|
(set! refresh-start (- refresh-start dellen))])
|
|
(cond
|
|
[(and (refresh-end . >= . start) (refresh-end . <= . end))
|
|
(set! refresh-end start)]
|
|
[(refresh-end . >= . end)
|
|
(set! refresh-end (- refresh-end dellen))]))
|
|
|
|
(set! extra-line? (has-flag? (snip->flags last-snip) NEWLINE))
|
|
|
|
(when (and scroll-ok? (= start startpos))
|
|
(set! delay-refresh (add1 delay-refresh))
|
|
(scroll-to-position/refresh startpos)
|
|
(set! delay-refresh (sub1 delay-refresh)))
|
|
|
|
(set! changed? #t)
|
|
|
|
(unless set-caret-style?
|
|
(set! caret-style #f))
|
|
|
|
(when (= len start)
|
|
;; force recheck extra line state:
|
|
(set! graphic-maybe-invalid? #t)
|
|
(set! graphic-maybe-invalid-force? #t))
|
|
|
|
(if deleted-line?
|
|
(begin
|
|
(set! graphic-maybe-invalid? #t)
|
|
(need-refresh start))
|
|
(refresh-by-line-demand))
|
|
|
|
(unless s-modified?
|
|
(set-modified #t))
|
|
|
|
(after-delete start dellen)
|
|
|
|
(when update-cursor?
|
|
(when s-admin
|
|
(send s-admin update-cursor))))))))))))
|
|
(assert (consistent-snip-lines 'post-do-delete))))
|
|
|
|
(define/public (delete . args)
|
|
(case-args
|
|
args
|
|
[()
|
|
(let ([streak? (= endpos startpos)]
|
|
[dstreak? deletion-streak?]
|
|
[dfs? delete-force-streak?])
|
|
(end-streaks '(delayed))
|
|
(set! delete-force-streak? dstreak?)
|
|
|
|
(delete startpos (if (= startpos endpos) 'back endpos))
|
|
|
|
(set! delete-force-streak? dfs?)
|
|
(set! deletion-streak? streak?))]
|
|
[([(make-alts exact-nonnegative-integer? (symbol-in start)) start]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in back)) [end 'back]]
|
|
[any? [scroll-ok? #t]])
|
|
(do-delete (if (symbol? start) startpos start) end #t scroll-ok?)]
|
|
(method-name 'text% 'delete)))
|
|
|
|
(def/public (erase)
|
|
(do-delete 0 len #t #t))
|
|
|
|
(def/override (clear)
|
|
(delete startpos endpos #t))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/override (cut [any? [extend? #f]] [exact-integer? [time 0]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in end)) [end 'end]])
|
|
(let* ([start (if (symbol? start)
|
|
startpos
|
|
start)]
|
|
[end (if (symbol? end)
|
|
endpos
|
|
end)]
|
|
[end (min end len)])
|
|
(unless (start . >= . end)
|
|
(copy extend? time start end)
|
|
(delete start end))))
|
|
|
|
(def/override (do-copy [exact-nonnegative-integer? startp]
|
|
[exact-nonnegative-integer? endp]
|
|
[exact-integer? time]
|
|
[bool? extend?])
|
|
(let ([startp (max startp 0)]
|
|
[endp (min endp len)])
|
|
(unless (endp . <= . startp)
|
|
|
|
(make-snipset startp endp)
|
|
|
|
(let ([sl (or (and extend? copy-style-list)
|
|
s-style-list)])
|
|
(set-common-copy-region-data! (get-region-data startp endp))
|
|
|
|
(let ([start (do-find-snip startp 'after)]
|
|
[end (do-find-snip endp 'after-or-none)]
|
|
[wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let loop ([snip start])
|
|
(unless (eq? snip end)
|
|
(let ([asnip (send snip copy)])
|
|
(snip-set-admin asnip #f)
|
|
(set-snip-style! asnip (send sl convert (snip->style asnip)))
|
|
(cons-common-copy-buffer! asnip)
|
|
(cons-common-copy-buffer2! (get-snip-data snip)))
|
|
(loop (snip->next snip))))
|
|
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
|
|
(install-copy-buffer time sl))))))
|
|
|
|
(def/override (copy [any? [extend? #f]] [exact-integer? [time 0]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in end)) [end 'end]])
|
|
(let* ([start (if (symbol? start)
|
|
startpos
|
|
start)]
|
|
[end (if (symbol? end)
|
|
endpos
|
|
end)]
|
|
[end (min end len)])
|
|
(unless (start . >= . end)
|
|
(begin-copy-buffer)
|
|
(unless extend?
|
|
(free-old-copies))
|
|
(do-copy start end time extend?)
|
|
(end-copy-buffer))))
|
|
|
|
(define/private (do-generic-paste cb start time)
|
|
(set! read-insert start)
|
|
(set! read-insert-start start)
|
|
(let ([orig-len len])
|
|
(do-buffer-paste cb time #f)
|
|
(let ([delta (- len orig-len)])
|
|
(set! prev-paste-start start)
|
|
(set! prev-paste-end (+ start delta)))))
|
|
|
|
(define/override (do-paste start time)
|
|
(do-generic-paste the-clipboard start time))
|
|
|
|
(define/override (do-paste-x-selection start time)
|
|
(do-generic-paste the-x-selection-clipboard start time))
|
|
|
|
(define/private (generic-paste x-sel? time start end)
|
|
(let* ([end (if (symbol? end)
|
|
(if (symbol? start)
|
|
endpos
|
|
start)
|
|
end)]
|
|
[start (if (eq? start 'start)
|
|
startpos
|
|
(if (symbol? start)
|
|
endpos
|
|
start))]
|
|
[end (min end len)])
|
|
(unless (start . > . end)
|
|
|
|
(begin-edit-sequence)
|
|
(when (start . < . end)
|
|
(delete start end))
|
|
|
|
(if x-sel?
|
|
(do-paste-x-selection start time)
|
|
(do-paste start time))
|
|
|
|
(let ([save-prev-paste prev-paste-start])
|
|
(end-edit-sequence)
|
|
(set! prev-paste-start save-prev-paste)))))
|
|
|
|
(def/override (paste [exact-integer? [time 0]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start end)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]])
|
|
(generic-paste #f time start end))
|
|
|
|
(def/override (paste-x-selection [exact-integer? [time 0]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start end)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]])
|
|
(generic-paste #t time start end))
|
|
|
|
(define/override (insert-paste-snip snip data)
|
|
(let ([addpos (snip->count snip)])
|
|
(insert snip read-insert)
|
|
(when data
|
|
(let ([snip (do-find-snip read-insert 'after)])
|
|
(set-snip-data snip data)))
|
|
(set! read-insert (+ read-insert addpos))))
|
|
|
|
(define/public (paste-region-data data)
|
|
(set-region-data read-insert-start read-insert data))
|
|
|
|
(define/override (insert-paste-string str)
|
|
(let* ([str (if (eq? 'windows (system-type))
|
|
(regexp-replace* #rx"\r\n" str "\n")
|
|
str)]
|
|
;; change non-breaking space to space:
|
|
[str (regexp-replace* #rx"\xA0" str " ")])
|
|
|
|
(insert str read-insert)
|
|
(set! read-insert (+ read-insert (string-length str)))))
|
|
|
|
(def/public (paste-next)
|
|
(unless (prev-paste-start . < . 0)
|
|
(let ([start prev-paste-start]
|
|
[end prev-paste-end])
|
|
|
|
(copy-ring-next)
|
|
(begin-edit-sequence)
|
|
(delete start end)
|
|
(set! read-insert start)
|
|
(set! read-insert-start start)
|
|
|
|
(let ([orig-len len])
|
|
(do-buffer-paste the-clipboard 0 #t)
|
|
|
|
(end-edit-sequence)
|
|
|
|
(let ([delta (- len orig-len)])
|
|
|
|
(set! prev-paste-start start)
|
|
(set! prev-paste-end (+ start delta)))))))
|
|
|
|
(define/private (do-kill time start end)
|
|
(let ([streak? kill-streak?])
|
|
|
|
(begin-edit-sequence)
|
|
(let-values ([(start end)
|
|
(if (symbol? start)
|
|
(let ([newend (paragraph-end-position (position-paragraph endpos posateol?))])
|
|
(if (= newend startpos)
|
|
(set-position startpos (+ startpos 1) #f #t 'local)
|
|
(begin
|
|
(set-position startpos newend #f #t 'local)
|
|
|
|
(let ([text (get-text startpos endpos)])
|
|
(let loop ([i (- endpos startpos)])
|
|
(if (zero? i)
|
|
;; line has all spaces: move one more
|
|
(set-position startpos (+ endpos 1) #f #t 'local)
|
|
(let ([i (sub1 i)])
|
|
(when (char-whitespace? (string-ref text i))
|
|
(loop i))))))))
|
|
(values startpos endpos))
|
|
(values start end))])
|
|
|
|
(cut streak? time start end)
|
|
(end-edit-sequence)
|
|
|
|
(set! kill-streak? #t))))
|
|
|
|
(define/override (kill . args)
|
|
(case-args
|
|
args
|
|
[([exact-integer? [time 0]])
|
|
(do-kill 0 'start 'end)]
|
|
[([exact-integer? time]
|
|
[exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? end])
|
|
(do-kill time start end)]
|
|
(method-name 'text% 'kill)))
|
|
|
|
(def/override (select-all)
|
|
(set-position 0 len))
|
|
|
|
(define/override (really-can-edit? op)
|
|
(cond
|
|
[read-locked? #f]
|
|
[(and (not (eq? 'copy op))
|
|
(or flow-locked? write-locked?))
|
|
#f]
|
|
[else
|
|
(case op
|
|
[(clear cut copy)
|
|
(not (= endpos startpos))]
|
|
[(kill)
|
|
(not (= len endpos))]
|
|
[(select-all)
|
|
(positive? len)]
|
|
[else #t])]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (split-snip [exact-nonnegative-integer? pos])
|
|
(unless (or flow-locked?
|
|
(pos . <= . 0)
|
|
(pos . >= . len))
|
|
(let ([wl? write-locked?])
|
|
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
(make-snipset pos pos)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? #f))))
|
|
|
|
(def/public (get-revision-number)
|
|
revision-count)
|
|
|
|
(def/override (get-flattened-text)
|
|
(get-text 0 'eof #t #f))
|
|
|
|
(def/public (get-text [exact-nonnegative-integer? [start 0]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]]
|
|
[any? [flat? #f]]
|
|
[any? [force-cr? #f]])
|
|
(if read-locked?
|
|
""
|
|
(let* ([end (if (eq? end 'eof)
|
|
len
|
|
end)]
|
|
[start (min start len)]
|
|
[end (max end start)]
|
|
[end (min end len)]
|
|
[count (- end start)])
|
|
(if (zero? count)
|
|
""
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?]
|
|
[p (open-output-string)])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let-values ([(snip s-pos) (find-snip/pos start 'after)])
|
|
(let loop ([snip snip]
|
|
[offset (- start s-pos)]
|
|
[count count])
|
|
(let ([num (min (- (snip->count snip) offset)
|
|
count)])
|
|
(if (not flat?)
|
|
(display (send-generic snip snip%-get-text offset num #f) p)
|
|
(begin
|
|
(display (send-generic snip snip%-get-text offset num #t) p)
|
|
(when (and force-cr?
|
|
(has-flag? (snip->flags snip) NEWLINE)
|
|
(not (has-flag? (snip->flags snip) HARD-NEWLINE)))
|
|
(display "\n" p))))
|
|
(let ([count (- count num)])
|
|
(if (zero? count)
|
|
(begin
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
(get-output-string p))
|
|
(loop (snip->next snip)
|
|
0
|
|
count)))))))))))
|
|
|
|
(def/public (get-character [exact-nonnegative-integer? start])
|
|
(if read-locked?
|
|
#\nul
|
|
(let-values ([(snip s-pos) (find-snip/pos (max 0 (min start len)) 'after)])
|
|
(let ([delta (- start s-pos)])
|
|
(if (delta . >= . (snip->count snip))
|
|
#\nul
|
|
(let ([buffer (make-string 1)])
|
|
(send snip get-text! buffer delta 1 0)
|
|
(string-ref buffer 0)))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (set-clickback [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? end]
|
|
[procedure? f]
|
|
[(make-or-false style-delta%) [c-delta #f]]
|
|
[any? [call-on-down? #f]])
|
|
(let ([delta (make-object style-delta%)])
|
|
(when c-delta
|
|
(send delta copy c-delta))
|
|
|
|
(let ([cb (make-clickback start
|
|
end
|
|
f
|
|
call-on-down?
|
|
delta
|
|
#f
|
|
null)])
|
|
(set! clickbacks (cons cb clickbacks)))))
|
|
|
|
(define/public (add-back-clickback cb)
|
|
(set! clickbacks (cons cb clickbacks)))
|
|
|
|
(def/public (remove-clickback [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? end])
|
|
(set! clickbacks
|
|
(filter (lambda (cb)
|
|
(not (and (= start (clickback-start cb))
|
|
(= end (clickback-start cb)))))
|
|
clickbacks)))
|
|
|
|
(def/public (call-clickback [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? end])
|
|
(for-each (lambda (cb)
|
|
(when (and ((clickback-start cb) . <= . start)
|
|
((clickback-end cb) . >= . end))
|
|
((clickback-f cb) this (clickback-start cb) (clickback-end cb))))
|
|
clickbacks))
|
|
|
|
|
|
(define/private (adjust-clickbacks start end d rec)
|
|
(when (pair? clickbacks)
|
|
(set! clickbacks
|
|
(filter (lambda (c)
|
|
(if (and ((clickback-start c) . >= . start)
|
|
((clickback-end c) . <= . end))
|
|
(begin
|
|
(when rec
|
|
(send rec add-clickback c))
|
|
#f)
|
|
#t))
|
|
clickbacks))
|
|
(for-each (lambda (c)
|
|
(cond
|
|
[((clickback-start c) . >= . end)
|
|
(set-clickback-start! c (+ (clickback-start c) d))
|
|
(set-clickback-end! c (+ (clickback-end c) d))]
|
|
[(and ((clickback-start c) . <= . start)
|
|
((clickback-end c) . >= . end))
|
|
(when (or (d . < . 0) ((clickback-end c) . > . end))
|
|
(set-clickback-end! c (+ (clickback-end c) d)))]
|
|
[(and ((clickback-start c) . > . start)
|
|
((clickback-end c) . > . end))
|
|
(set-clickback-start! c start)
|
|
(set-clickback-end! c (+ (clickback-end c) d))]))
|
|
clickbacks)
|
|
(set! clickbacks
|
|
(filter (lambda (c)
|
|
(if (= (clickback-start c) (clickback-end c))
|
|
(when rec
|
|
(send rec add-clickback c)
|
|
#f)
|
|
#t))
|
|
clickbacks))))
|
|
|
|
(define/private (find-clickback start y)
|
|
(ormap (lambda (c)
|
|
(and ((clickback-start c) . <= . start)
|
|
((clickback-end c) . > . start)
|
|
;; we're in the right horizontal region, but maybe the mouse
|
|
;; is above or below the clickback
|
|
(let ([start (do-find-snip (clickback-start c) 'after)]
|
|
[end (do-find-snip (clickback-end c) 'before)])
|
|
(and start
|
|
end
|
|
(let-boxes ([top 0.0]
|
|
[bottom 0.0])
|
|
(begin
|
|
(get-snip-location start #f top #f)
|
|
(get-snip-location start #f bottom #t))
|
|
(let loop ([start start]
|
|
[top top]
|
|
[bottom bottom])
|
|
(if (eq? end start)
|
|
(and (y . >= . top)
|
|
(y . <= . bottom)
|
|
c)
|
|
(let ([start (snip->next start)])
|
|
(let-boxes ([ntop 0.0]
|
|
[nbottom 0.0])
|
|
(begin
|
|
(get-snip-location start #f ntop #f)
|
|
(get-snip-location start #f nbottom #t))
|
|
(loop start
|
|
(min ntop top)
|
|
(max nbottom bottom)))))))))))
|
|
clickbacks))
|
|
|
|
(define/private (set-clickback-hilited c on?)
|
|
(when (not (eq? (and on? #t)
|
|
(clickback-hilited? c)))
|
|
(cond
|
|
[on?
|
|
(s-start-intercept)
|
|
|
|
(begin-edit-sequence)
|
|
(flash-on (clickback-start c) (clickback-end c) #f #f 0)
|
|
(do-change-style (clickback-start c) (clickback-end c) #f (clickback-delta c) #f)
|
|
(end-edit-sequence)
|
|
|
|
(set-clickback-unhilite! c (s-end-intercept))]
|
|
[else
|
|
(perform-undo-list (clickback-unhilite c))
|
|
(set-clickback-unhilite! c null)
|
|
(flash-off)])
|
|
(set-clickback-hilited?! (and on? #t))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (flash-on [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? end]
|
|
[any? [ateol? #f]]
|
|
[any? [scroll? #t]]
|
|
[exact-nonnegative-integer? [timeout 500]])
|
|
(do-set-position #t 'none start end ateol? scroll? 'default)
|
|
(when (timeout . > . 0)
|
|
(set! flashautoreset? #t)
|
|
(when flash-timer
|
|
(send flash-timer stop))
|
|
(set! flash-timer (new flash-timer% [editor this]))
|
|
(send flash-timer start timeout))
|
|
(set! flashscroll? scroll?))
|
|
|
|
(def/public (flash-off)
|
|
(when flash?
|
|
(set! flashautoreset? #t)
|
|
(set! flashdirectoff? #t)
|
|
(do-set-position #f 'none startpos endpos posateol? flashscroll? 'default)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (set-wordbreak-func [procedure? f])
|
|
(set! word-break f))
|
|
|
|
(def/public (find-wordbreak [(make-or-false (make-box exact-nonnegative-integer?)) start]
|
|
[(make-or-false (make-box exact-nonnegative-integer?)) end]
|
|
[(symbol-in caret line selection user1 user2) reason])
|
|
(unless read-locked?
|
|
(let ([oldstart (if start (unbox start) 0)]
|
|
[oldend (if end (unbox end) 0)])
|
|
(word-break this start end reason)
|
|
|
|
(when (and start ((unbox start) . > . oldstart))
|
|
(set-box! start oldstart))
|
|
(when (and end ((unbox end) . < . oldend))
|
|
(set-box! end oldend)))))
|
|
|
|
(def/public (get-wordbreak-map)
|
|
word-break-map)
|
|
|
|
(def/public (set-wordbreak-map [(make-or-false editor-wordbreak-map%) map])
|
|
(set! word-break-map map))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (set-line-spacing [nonnegative-real? s])
|
|
(unless (or flow-locked?
|
|
(= line-spacing s))
|
|
(set! line-spacing s)
|
|
(size-cache-invalid)
|
|
(set! changed? #t)
|
|
(need-refresh -1 -1)))
|
|
|
|
(def/public (get-line-spacing) line-spacing)
|
|
|
|
(def/override (get-max-width)
|
|
(if (max-width . <= . 0)
|
|
'none
|
|
(+ max-width wrap-bitmap-width)))
|
|
|
|
(def/override (get-min-width)
|
|
(if (min-width . <= . 0)
|
|
'none
|
|
min-width))
|
|
|
|
(def/override (set-max-width [(make-alts nonnegative-real? (symbol-in none)) w])
|
|
(unless flow-locked?
|
|
(let* ([w (if (eq? w 'none) 0.0 w)]
|
|
[w (if (and (positive? wrap-bitmap-width) (w . > . 0))
|
|
(let ([w (- w wrap-bitmap-width)])
|
|
(if (w . <= . 0.0)
|
|
(+ CURSOR-WIDTH 1)
|
|
w))
|
|
w)])
|
|
(unless (or (= max-width w)
|
|
(and (w . <= . 0) (max-width . <= . 0))
|
|
(not (can-set-size-constraint?)))
|
|
(on-set-size-constraint)
|
|
|
|
(let ([w (if (and (w . > . 0)
|
|
(w . < . (+ CURSOR-WIDTH 1)))
|
|
(+ CURSOR-WIDTH 1)
|
|
w)])
|
|
(set! max-width w)
|
|
(set! flow-invalid? #t)
|
|
(set! graphic-maybe-invalid? #t)
|
|
(set! changed? #t)
|
|
(need-refresh -1 -1)
|
|
|
|
(after-set-size-constraint))))))
|
|
|
|
(define/private (set-m-x v current setter)
|
|
(let ([v (if (eq? v 'none) 0.0 v)])
|
|
(unless (or flow-locked?
|
|
(= current v)
|
|
(and (v . <= . 0) (current . <= . 0))
|
|
(not (can-set-size-constraint?)))
|
|
(on-set-size-constraint)
|
|
|
|
(set! graphic-maybe-invalid? #t)
|
|
(set! graphic-maybe-invalid-force? #t)
|
|
(setter v)
|
|
(set! changed? #t)
|
|
(need-refresh -1 -1)
|
|
|
|
(after-set-size-constraint))))
|
|
|
|
(def/override (set-min-width [(make-alts nonnegative-real? (symbol-in none)) w])
|
|
(set-m-x w min-width (lambda (w) (set! min-width w))))
|
|
|
|
(def/override (set-min-height [(make-alts nonnegative-real? (symbol-in none)) h])
|
|
(set-m-x h min-height (lambda (h) (set! min-height h))))
|
|
|
|
(def/override (set-max-height [(make-alts nonnegative-real? (symbol-in none)) h])
|
|
(set-m-x h max-height (lambda (h) (set! max-height h))))
|
|
|
|
(def/override (get-min-height)
|
|
(if (min-height . <= . 0)
|
|
'none
|
|
min-height))
|
|
|
|
(def/override (get-max-height)
|
|
(if (max-height . <= . 0)
|
|
'none
|
|
max-height))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/override (insert-port [input-port? f]
|
|
[(symbol-in guess same copy standard text text-force-cr) [format 'guess]]
|
|
[any? [replace-styles? #t]])
|
|
(if (or write-locked? s-user-locked?)
|
|
'guess ;; FIXME: docs say that this is more specific
|
|
(do-insert-file (method-name 'text% 'insert-file) f format replace-styles?)))
|
|
|
|
(define/private (do-insert-file who f fmt clear-styles?)
|
|
(let ([fmt
|
|
(cond
|
|
[(or (eq? 'guess fmt) (eq? 'same fmt) (eq? 'copy fmt))
|
|
(if (not (detect-wxme-file who f #t))
|
|
'text
|
|
'standard)]
|
|
[else fmt])])
|
|
|
|
(let ([fileerr?
|
|
(cond
|
|
[(eq? 'standard fmt)
|
|
(if (not (detect-wxme-file who f #f))
|
|
(error who "not a WXME file")
|
|
(let* ([b (make-object editor-stream-in-file-base% f)]
|
|
[mf (make-object editor-stream-in% b)])
|
|
(or (and (not (read-editor-version mf b #f #t))
|
|
'read-editor-version-failed)
|
|
(and (not (read-editor-global-header mf))
|
|
'read-editor-global-head-failed)
|
|
(and (not (send mf ok?))
|
|
'mf-not-ok)
|
|
(and (not (read-from-file mf clear-styles?))
|
|
'read-from-file-failed)
|
|
(and (not (read-editor-global-footer mf))
|
|
'read-editor-gobal-footer-failed)
|
|
(begin
|
|
;; if STD-STYLE wasn't loaded, re-create it:
|
|
(send s-style-list new-named-style "Standard" (send s-style-list basic-style))
|
|
(and (not (send mf ok?))
|
|
'mf-not-okay-after-adding-standard-style)))))]
|
|
[(or (eq? fmt 'text) (eq? fmt 'text-force-cr))
|
|
(let ([s (make-string 1024)])
|
|
(let loop ([saved-cr? #f])
|
|
(let ([len (read-string! s f)])
|
|
(unless (eof-object? len)
|
|
(let* ([s1 (if (= len (string-length s))
|
|
s
|
|
(substring s 0 len))]
|
|
[s2 (if (equal? #\return (string-ref s1 (sub1 len)))
|
|
(substring s1 0 (sub1 len))
|
|
s1)])
|
|
(insert (regexp-replace* #rx"\r\n"
|
|
(if saved-cr? (string-append "\r" s2) s2)
|
|
"\n"))
|
|
(loop (not (eq? s1 s2))))))))
|
|
#f])])
|
|
|
|
(when fileerr?
|
|
(error who "error loading the file~a" (if (boolean? fileerr?)
|
|
""
|
|
(format " (~a)" fileerr?))))
|
|
|
|
fmt)))
|
|
|
|
(def/override (save-port [output-port? f]
|
|
[(symbol-in guess same copy standard text text-force-cr) [format 'same]]
|
|
[any? [show-errors? #t]])
|
|
(when read-locked?
|
|
(error (method-name 'text% 'save-file) "editor locked for reading"))
|
|
|
|
(let ([format
|
|
(cond
|
|
[(or (eq? 'same format) (eq? 'guess format) (eq? 'copy format))
|
|
file-format]
|
|
[else format])])
|
|
|
|
(let ([fileerr?
|
|
(cond
|
|
[(or (eq? 'text format) (eq? 'text-force-cr format))
|
|
(display (get-text 0 'eof #t (eq? format 'text-force-cr)) f)
|
|
#f]
|
|
[else
|
|
(let* ([b (make-object editor-stream-out-file-base% f)]
|
|
[mf (make-object editor-stream-out% b)])
|
|
(not (and (write-editor-version mf b)
|
|
(write-editor-global-header mf)
|
|
(send mf ok?)
|
|
(write-to-file mf)
|
|
(write-editor-global-footer mf)
|
|
(send mf ok?))))])])
|
|
(when fileerr?
|
|
(error (method-name 'text% 'save-port) "error writing editor content"))
|
|
#t)))
|
|
|
|
(define/private (do-read-from-file f start overwritestyle?)
|
|
(if write-locked?
|
|
#f
|
|
(let ([start (if (symbol? start)
|
|
startpos
|
|
start)])
|
|
(set! read-insert start)
|
|
(let ([result (read-snips-from-file f overwritestyle?)])
|
|
|
|
(when (zero? len)
|
|
;; we probably destructively changed the style list; reset the dummy snip
|
|
(set-snip-style! snips (or (get-default-style)
|
|
(send s-style-list basic-style))))
|
|
|
|
result))))
|
|
|
|
(define/override (read-from-file . args)
|
|
(case-args
|
|
args
|
|
[([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #f]])
|
|
(do-read-from-file f start overwritestyle?)]
|
|
[([editor-stream-in% f] [any? [overwritestyle? #f]])
|
|
(do-read-from-file f 'start overwritestyle?)]
|
|
(method-name 'text% 'read-from-file)))
|
|
|
|
(define/override (do-read-insert snip)
|
|
(if (list? snip)
|
|
(let ([oldlen len])
|
|
(do-insert #f #f snip startpos startpos #t)
|
|
(set! read-insert (+ read-insert (- len oldlen)))
|
|
#t)
|
|
(let ([addpos (snip->count snip)])
|
|
(do-insert snip #f #f startpos startpos #t)
|
|
(set! read-insert (+ addpos read-insert))
|
|
#t)))
|
|
|
|
(def/override (write-to-file [editor-stream-out% f]
|
|
[exact-nonnegative-integer? [start 0]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]])
|
|
(if read-locked?
|
|
#f
|
|
(let ([end (max (if (eq? end 'eof)
|
|
len
|
|
end)
|
|
start)])
|
|
(let ([start-snip (if (zero? len) #f (do-find-snip start 'after))]
|
|
[end-snip (if (zero? len) #f (do-find-snip end 'after-or-none))])
|
|
(and (do-write-headers-footers f #t)
|
|
(write-snips-to-file f s-style-list #f start-snip end-snip #f this)
|
|
(do-write-headers-footers f #f))))))
|
|
|
|
(def/public (get-file-format) file-format)
|
|
(def/public (set-file-format [(symbol-in standard text text-force-cr) format])
|
|
(set! file-format format))
|
|
|
|
(def/override (set-filename [(make-or-false path-string?) name][any? [temp? #f]])
|
|
(set! s-filename (if (string? name)
|
|
(string->path name)
|
|
name))
|
|
(set! s-temp-filename? temp?)
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let loop ([snip snips])
|
|
(when snip
|
|
(when (has-flag? (snip->flags snip) USES-BUFFER-PATH)
|
|
(send snip set-admin snip-admin))
|
|
(loop (snip->next snip))))
|
|
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (get-region-data [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? end])
|
|
#f)
|
|
|
|
(def/public (set-region-data [exact-nonnegative-integer? start]
|
|
[exact-nonnegative-integer? end]
|
|
[editor-data% d])
|
|
(void))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (get-tabs [maybe-box? [count #f]]
|
|
[maybe-box? [space #f]]
|
|
[maybe-box? [in-units #f]])
|
|
(when count
|
|
(set-box! count (vector-length tabs)))
|
|
(when space
|
|
(set-box! space (if (symbol? tab-space)
|
|
#f
|
|
tab-space)))
|
|
(when in-units
|
|
(set-box! in-units tab-space-in-units?))
|
|
|
|
(vector->list tabs))
|
|
|
|
(def/public (set-tabs [(make-list real?) newtabs]
|
|
[(make-alts real? (symbol-in tab-width)) [tab-width 20]]
|
|
[any? [in-units? #t]])
|
|
(unless flow-locked?
|
|
(set! tabs (list->vector newtabs))
|
|
|
|
(if (and (number? tab-width) (tab-width . >= . 1))
|
|
(set! tab-space (exact->inexact tab-width))
|
|
(set! tab-space TAB-WIDTH))
|
|
|
|
(set! tab-space-in-units? in-units?)
|
|
|
|
(size-cache-invalid)
|
|
(set! changed? #t)
|
|
(need-refresh -1 -1)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (do-find-position-in-line internal? i x ateol?-box onit?-box how-close-box)
|
|
(when onit?-box
|
|
(set-box! onit?-box #f))
|
|
(when ateol?-box
|
|
(set-box! ateol?-box #f))
|
|
(when how-close-box
|
|
(set-box! how-close-box 100.0))
|
|
|
|
(cond
|
|
[(and (not internal?) (not (check-recalc #t #f)))
|
|
0]
|
|
[(i . < . 0) 0]
|
|
[(i . >= . num-valid-lines) len]
|
|
[else
|
|
(let* ([line (mline-find-line (unbox line-root-box) i)]
|
|
[x (- x (mline-get-left-location line max-width))])
|
|
(if (x . <= . 0)
|
|
(find-first-visible-position line)
|
|
(let ([p (mline-get-position line)])
|
|
(let-values ([(snip s-pos p)
|
|
(if (x . >= . (mline-w line))
|
|
;; snip == the last one
|
|
(let ([snip (mline-last-snip line)])
|
|
(values snip
|
|
(+ p (- (mline-len line) (snip->count snip)))
|
|
(+ p (mline-len line))))
|
|
(begin
|
|
(when onit?-box
|
|
(set-box! onit?-box #t))
|
|
|
|
(let ([dc (send s-admin get-dc)]
|
|
[X 0]
|
|
[wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
;; linear seach for snip
|
|
(let ([topy (mline-get-location line)])
|
|
(let loop ([snip (mline-snip line)]
|
|
[X X]
|
|
[x x]
|
|
[p p])
|
|
(let-boxes ([w 0.0])
|
|
(when dc (send snip get-extent dc X topy w #f #f #f #f #f))
|
|
(if (and (x . > . w) (snip->next snip) dc)
|
|
(loop (snip->next snip)
|
|
(+ X w)
|
|
(- x w)
|
|
(+ p (snip->count snip)))
|
|
;; found the right snip
|
|
(let ([s-pos p]
|
|
[p (+ p (do-find-position-in-snip dc X topy snip x how-close-box))])
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
(values snip s-pos p)))))))))])
|
|
|
|
;; back up over invisibles
|
|
(let ([atsnipend? (- (- p s-pos) (snip->count snip))])
|
|
(let-boxes ([p p]
|
|
[snip snip])
|
|
(when atsnipend?
|
|
(find-last-visible-position line p snip))
|
|
(when (and ateol?-box
|
|
atsnipend?
|
|
snip
|
|
(eq? snip (mline-last-snip line)))
|
|
(set-box! ateol?-box #t))
|
|
p))))))]))
|
|
|
|
(define/private (find-first-visible-position line [snip #f])
|
|
(if read-locked?
|
|
0
|
|
(let* ([snip (or snip (mline-snip line))]
|
|
[startp (mline-get-position line)]
|
|
[p startp]
|
|
[next-snip (snip->next (mline-last-snip line))])
|
|
(let loop ([snip snip]
|
|
[p p])
|
|
(cond
|
|
[(eq? snip next-snip)
|
|
;; if everything is invisible, then presumably the CR is forced,
|
|
;; so go to the beginning of the line anyway
|
|
startp]
|
|
[(has-flag? (snip->flags snip) INVISIBLE)
|
|
(loop (snip->next snip) (+ p (snip->count snip)))]
|
|
[else p])))))
|
|
|
|
(define/private (find-last-visible-position line p-box [snip-box #f])
|
|
(unless read-locked?
|
|
(let ([snip (or (if snip-box
|
|
(unbox snip-box)
|
|
#f)
|
|
(mline-last-snip line))]
|
|
[p (unbox p-box)])
|
|
(let loop ([p p]
|
|
[snip snip])
|
|
(let ([p (if (has-flag? (snip->flags snip) INVISIBLE)
|
|
(- p (snip->count snip))
|
|
p)])
|
|
(if (eq? snip (mline-snip line))
|
|
(begin
|
|
(set-box! p-box p)
|
|
(when snip-box
|
|
(set-box! snip-box snip)))
|
|
(loop p (snip->prev snip))))))))
|
|
|
|
(def/public (find-position-in-line [exact-nonnegative-integer? i]
|
|
[real? x]
|
|
[maybe-box? [ateol? #f]]
|
|
[maybe-box? [onit? #f]]
|
|
[maybe-box? [how-close #f]])
|
|
(do-find-position-in-line #f i x ateol? onit? how-close))
|
|
|
|
(define/private (do-find-position-in-snip dc X Y snip x how-close)
|
|
(cond
|
|
[read-locked? 0]
|
|
[(x . < . 0)
|
|
(when how-close
|
|
(set-box! how-close -100.0))
|
|
0]
|
|
[else
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let ([c (snip->count snip)])
|
|
(if ((send snip partial-offset dc X Y c) . <= . x)
|
|
(begin
|
|
(when how-close
|
|
(set-box! how-close 100.0))
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
c)
|
|
|
|
;; binary search for position within snip:
|
|
(let loop ([range c]
|
|
[i (quotient c 2)]
|
|
[offset 0])
|
|
(let ([dl (send snip partial-offset dc X Y (+ offset i))])
|
|
(if (dl . > . x)
|
|
(loop i (quotient i 2) offset)
|
|
(let ([dr (send snip partial-offset dc X Y (+ offset i 1))])
|
|
(if (dr . <= . x)
|
|
(let ([range (- range i)])
|
|
(loop range (quotient range 2) (+ offset i)))
|
|
(begin
|
|
(when how-close
|
|
(set-box! how-close
|
|
(if ((- dr x) . < . (- x dl))
|
|
(- dr x)
|
|
(- dl x))))
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
(+ i offset))))))))))]))
|
|
|
|
(def/public (find-line [real? y] [maybe-box? [onit? #f]])
|
|
(when onit?
|
|
(set-box! onit? #f))
|
|
|
|
(cond
|
|
[(not (check-recalc #t #f)) 0]
|
|
[(y . <= . 0) 0]
|
|
[(or (y . >= . total-height) (and extra-line? (y . >= . (- total-height extra-line-h))))
|
|
(- num-valid-lines (if extra-line? 0 1))]
|
|
[else
|
|
(when onit?
|
|
(set-box! onit? #t))
|
|
(mline-get-line (mline-find-location (unbox line-root-box) y))]))
|
|
|
|
(def/public (find-position [real? x] [real? y]
|
|
[maybe-box? [ateol? #f]]
|
|
[maybe-box? [onit? #f]]
|
|
[maybe-box? [how-close #f]])
|
|
(if read-locked?
|
|
0
|
|
(begin
|
|
(when ateol?
|
|
(set-box! ateol? #f))
|
|
|
|
(let* ([online (box #f)]
|
|
[i (find-line y online)])
|
|
(if (and (i . >= . (- num-valid-lines 1))
|
|
(not (unbox online))
|
|
(y . > . 0))
|
|
(begin
|
|
(when onit?
|
|
(set-box! onit? #f))
|
|
(when how-close
|
|
(set-box! how-close 100.0))
|
|
len)
|
|
(let ([p (find-position-in-line i x ateol? onit? how-close)])
|
|
(when onit?
|
|
(set-box! onit? (and (unbox online) (unbox onit?))))
|
|
p))))))
|
|
|
|
(def/public (position-line [exact-nonnegative-integer? start]
|
|
[any? [eol? #f]])
|
|
(cond
|
|
[(not (check-recalc (max-width . > . 0) #f #t)) 0]
|
|
[(start . <= . 0) 0]
|
|
[(start . >= . len)
|
|
(if (and extra-line? (not eol?))
|
|
num-valid-lines
|
|
(- num-valid-lines 1))]
|
|
[else
|
|
(let* ([line (mline-find-position (unbox line-root-box) start)]
|
|
[line (if (and eol? (= (mline-get-position line) start))
|
|
(mline-prev line)
|
|
line)])
|
|
(mline-get-line line))]))
|
|
|
|
|
|
(def/public-final (get-snip-position-and-location [snip% thesnip] [maybe-box? pos]
|
|
[maybe-box? [x #f]] [maybe-box? [y #f]])
|
|
(cond
|
|
[(not (check-recalc (or x y) #f))
|
|
#f]
|
|
[(or (not (snip->line thesnip))
|
|
(not (eq? (mline-get-root (snip->line thesnip)) (unbox line-root-box))))
|
|
#f]
|
|
[(or pos x y)
|
|
(let* ([line (snip->line thesnip)]
|
|
[p (mline-get-position line)])
|
|
(let loop ([snip (mline-snip line)]
|
|
[p p])
|
|
(if (eq? snip thesnip)
|
|
(begin
|
|
(when pos
|
|
(set-box! pos p))
|
|
(when (or x y)
|
|
(position-location p x y))
|
|
#t)
|
|
(loop (snip->next snip)
|
|
(+ p (snip->count snip))))))]
|
|
[else #t]))
|
|
|
|
(def/override (get-snip-location [snip% thesnip] [maybe-box? [x #f]] [maybe-box? [y #f]] [any? [bottom-right? #f]])
|
|
(let ([x (or x (and bottom-right? (box 0.0)))]
|
|
[y (or y (and bottom-right? (box 0.0)))])
|
|
(if (get-snip-position-and-location thesnip #f x y)
|
|
(if bottom-right?
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let ([dc (send s-admin get-dc)])
|
|
(let-boxes ([w 0.0]
|
|
[h 0.0])
|
|
(when dc
|
|
(send thesnip get-extent dc (unbox x) (unbox y) w h #f #f #f #f))
|
|
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
|
|
(set-box! x (+ (unbox x) w))
|
|
(set-box! y (+ (unbox y) h))
|
|
#t)))
|
|
#t)
|
|
#f)))
|
|
|
|
(def/public (get-snip-position [snip% thesnip])
|
|
(let-boxes ([pos 0])
|
|
(unless (get-snip-position-and-location thesnip pos)
|
|
(set-box! pos #f))
|
|
pos))
|
|
|
|
(def/public (position-locations [exact-nonnegative-integer? start]
|
|
[maybe-box? [tx #f]]
|
|
[maybe-box? [ty #f]]
|
|
[maybe-box? [bx #f]]
|
|
[maybe-box? [by #f]]
|
|
[any? [eol? #f]]
|
|
[any? [whole-line? #f]])
|
|
(when (check-recalc #t #f)
|
|
|
|
;; handle boundary cases first:
|
|
(let ([line
|
|
(cond
|
|
[(start . <= . 0)
|
|
(if whole-line?
|
|
(begin
|
|
(when (or tx bx)
|
|
(let ([xl (mline-get-left-location first-line max-width)])
|
|
(when tx (set-box! tx xl))
|
|
(when bx (set-box! bx xl))))
|
|
(when (or ty by)
|
|
(let ([yl (mline-get-location first-line)])
|
|
(when ty (set-box! ty yl))
|
|
(when by (set-box! by (+ yl (mline-h first-line))))))
|
|
#f)
|
|
first-line)]
|
|
[(start . >= . len)
|
|
(if (and extra-line? (not eol?))
|
|
(begin
|
|
(when ty (set-box! ty (- total-height extra-line-h)))
|
|
(when by (set-box! by total-height))
|
|
(when tx (set-box! tx 0))
|
|
(when bx (set-box! bx 0))
|
|
#f)
|
|
(if (or whole-line? (zero? len))
|
|
(begin
|
|
(when (or tx bx)
|
|
(let ([xl (mline-get-right-location last-line max-width)])
|
|
(when tx (set-box! tx xl))
|
|
(when bx (set-box! bx xl))))
|
|
(when (or ty by)
|
|
(let ([yl (mline-get-location last-line)])
|
|
(when ty (set-box! ty yl))
|
|
(when by (set-box! by (+ yl (mline-h last-line))))))
|
|
#f)
|
|
last-line))]
|
|
[else
|
|
(let ([line (mline-find-line (unbox line-root-box) (position-line start eol?))])
|
|
(if whole-line?
|
|
(begin
|
|
(when (or by ty)
|
|
(let ([yl (mline-get-location line)])
|
|
(when ty (set-box! ty yl))
|
|
(when by (set-box! by (+ yl (mline-h line))))))
|
|
(if (not (or tx bx))
|
|
#f
|
|
line))
|
|
line))])])
|
|
(when line
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let ([horiz (mline-get-left-location line max-width)]
|
|
[topy (mline-get-location line)]
|
|
[start (- start (mline-get-position line))])
|
|
(let-values ([(snip horiz start dc)
|
|
(cond
|
|
[(zero? start) (values (mline-snip line) horiz start #f)]
|
|
[(start . >= . (mline-len line))
|
|
(values (mline-last-snip line) (+ horiz (- (mline-w line) (mline-last-w line)))
|
|
start #f)]
|
|
[else
|
|
;; linear seach for snip
|
|
(let loop ([snip (mline-snip line)]
|
|
[start start]
|
|
[horiz horiz]
|
|
[dc #f])
|
|
(if (or (start . > . (snip->count snip))
|
|
(and (or whole-line? (positive? start))
|
|
(= start (snip->count snip))))
|
|
(let* ([start (- start (snip->count snip))]
|
|
[dc (or dc (send s-admin get-dc))])
|
|
(let-boxes ([v 1.0])
|
|
(when dc
|
|
(send snip get-extent dc horiz topy v #f #f #f #f #f))
|
|
(loop (snip->next snip) start (+ horiz v) dc)))
|
|
;; found snip
|
|
(values snip horiz start dc)))])])
|
|
(let ([dc
|
|
(if (or tx bx)
|
|
(let ([dc (or dc
|
|
(and (positive? start)
|
|
(send s-admin get-dc)))])
|
|
(let ([xv (+ horiz
|
|
(if (and dc (positive? start))
|
|
(send snip partial-offset dc horiz topy start)
|
|
0))])
|
|
(when tx (set-box! tx xv))
|
|
(when bx (set-box! bx xv)))
|
|
dc)
|
|
dc)])
|
|
(when (and (not whole-line?)
|
|
(or ty by))
|
|
(let ([dc (or dc (send s-admin get-dc))])
|
|
(let-boxes ([h 0.0]
|
|
[descent 0.0]
|
|
[space 0.0])
|
|
(when dc
|
|
(send snip get-extent dc horiz topy #f h descent space #f #F))
|
|
(let ([align (send (snip->style snip) get-alignment)])
|
|
(cond
|
|
[(eq? 'bottom align)
|
|
(let ([yl (+ topy (mline-bottombase line) descent)])
|
|
(when ty (set-box! ty (- yl h)))
|
|
(when by (set-box! by yl)))]
|
|
[(eq? 'top align)
|
|
(let ([yl (- (+ topy (mline-topbase line)) space)])
|
|
(when ty (set-box! ty yl))
|
|
(when by (set-box! by (+ yl h))))]
|
|
[else
|
|
(let* ([h (/ (- h descent space) 2)]
|
|
[yl (+ topy (/ (+ (mline-topbase line) (mline-bottombase line)) 2))])
|
|
(when ty (set-box! ty (- yl h space)))
|
|
(when by (set-box! by (+ yl h descent))))])))))
|
|
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)))))))))
|
|
|
|
(def/public (position-location [exact-nonnegative-integer? start]
|
|
[maybe-box? [x #f]]
|
|
[maybe-box? [y #f]]
|
|
[any? [top? #t]]
|
|
[any? [eol? #f]]
|
|
[any? [whole-line? #f]])
|
|
(position-locations start
|
|
(if top? x #f) (if top? y #f)
|
|
(if top? #f x) (if top? #f y)
|
|
eol? whole-line?))
|
|
|
|
(def/public (line-location [exact-nonnegative-integer? i]
|
|
[any? [top? #t]])
|
|
(cond
|
|
[(not (check-recalc #t #f)) 0.0]
|
|
[(i . < . 0) 0.0]
|
|
[(i . > . num-valid-lines) total-height]
|
|
[(= num-valid-lines i)
|
|
(if extra-line?
|
|
(- total-height extra-line-h)
|
|
total-height)]
|
|
[else
|
|
(let* ([line (mline-find-line (unbox line-root-box) i)]
|
|
[y (mline-get-location line)])
|
|
(if top?
|
|
y
|
|
(+ y (mline-h line))))]))
|
|
|
|
(define/private (do-line-position start? i visible-only?)
|
|
(cond
|
|
[(not (check-recalc (max-width . > . 0) #f #t))
|
|
0]
|
|
[(and (i . >= . num-valid-lines) extra-line?)
|
|
len]
|
|
[else (let* ([i (max 0 (min i (sub1 num-valid-lines)))]
|
|
[line (mline-find-line (unbox line-root-box) i)])
|
|
(if start?
|
|
(if visible-only?
|
|
(find-first-visible-position line)
|
|
(mline-get-position line))
|
|
(let ([p (+ (mline-get-position line) (mline-len line))])
|
|
(if visible-only?
|
|
(let-boxes ([p p])
|
|
(find-last-visible-position line p)
|
|
p)
|
|
p))))]))
|
|
|
|
(def/public (line-start-position [exact-nonnegative-integer? i]
|
|
[any? [visible-only? #t]])
|
|
(do-line-position #t i visible-only?))
|
|
|
|
(def/public (line-end-position [exact-nonnegative-integer? i]
|
|
[any? [visible-only? #t]])
|
|
(do-line-position #f i visible-only?))
|
|
|
|
|
|
(def/public (line-length [exact-nonnegative-integer? i])
|
|
(cond
|
|
[(not (check-recalc (max-width . > . 0) #f #t))
|
|
0]
|
|
[(i . < . 0) 0]
|
|
[(i . >= . num-valid-lines) 0]
|
|
[else (let ([line (mline-find-line (unbox line-root-box) i)])
|
|
(mline-len line))]))
|
|
|
|
(def/public (position-paragraph [exact-nonnegative-integer? i]
|
|
[any? [at-eol? #f]])
|
|
(cond
|
|
[(not (check-recalc #f #f #t)) 0]
|
|
[else (let ([delta (if (and (i . >= . len) extra-line?)
|
|
1
|
|
0)]
|
|
[i (max 0 (min i len))])
|
|
(let ([line (mline-find-position (unbox line-root-box) i)])
|
|
(+ (mline-get-paragraph line) delta)))]))
|
|
|
|
(def/public (paragraph-start-position [exact-nonnegative-integer? i]
|
|
[any? [visible-only? #t]])
|
|
(if (not (check-recalc #f #f #t))
|
|
0
|
|
(if (i . > . (+ (last-paragraph) (if extra-line? -1 0)))
|
|
len
|
|
(let* ([i (max 0 i)]
|
|
[l (mline-find-paragraph (unbox line-root-box) i)]
|
|
[l (if (not l)
|
|
(if extra-line?
|
|
len
|
|
(let loop ([l last-line])
|
|
(if (and (mline-prev l)
|
|
(not (mline-starts-paragraph l)))
|
|
(loop (mline-prev l))
|
|
l)))
|
|
l)])
|
|
(if visible-only?
|
|
(find-first-visible-position l)
|
|
(mline-get-position l))))))
|
|
|
|
(def/public (paragraph-end-position [exact-nonnegative-integer? i]
|
|
[any? [visible-only? #t]])
|
|
(if (not (check-recalc #f #f #t))
|
|
0
|
|
(let* ([i (max 0 i)]
|
|
[l (mline-find-paragraph (unbox line-root-box) i)]
|
|
[l (if l
|
|
(let loop ([l l])
|
|
(if (and (mline-next l)
|
|
(zero? (mline-starts-paragraph (mline-next l))))
|
|
(loop (mline-next l))
|
|
l))
|
|
(if extra-line?
|
|
len
|
|
last-line))])
|
|
(if (mline? l)
|
|
(let ([p (+ (mline-get-position l) (mline-len l))])
|
|
(if visible-only?
|
|
(let-boxes ([p p])
|
|
(find-last-visible-position l p)
|
|
p)
|
|
p))
|
|
l))))
|
|
|
|
(def/public (line-paragraph [exact-nonnegative-integer? i])
|
|
(cond
|
|
[(not (check-recalc (max-width . > . 0) #f #t))
|
|
0]
|
|
[(i . < . 0) 0]
|
|
[(i . >= . num-valid-lines)
|
|
(+ (mline-get-paragraph last-line) (if extra-line? 1 0))]
|
|
[else
|
|
(let ([l (mline-find-line (unbox line-root-box) i)])
|
|
(mline-get-paragraph l))]))
|
|
|
|
(def/public (paragraph-start-line [exact-nonnegative-integer? i])
|
|
(if (not (check-recalc (max-width . > . 0) #f #t))
|
|
0
|
|
(let* ([i (max i 0)]
|
|
[l (mline-find-paragraph (unbox line-root-box) i)])
|
|
(if (not l)
|
|
(last-line)
|
|
(mline-get-line l)))))
|
|
|
|
(def/public (paragraph-end-line [exact-nonnegative-integer? i])
|
|
(if (not (check-recalc (max-width . > . 0) #f #t))
|
|
0
|
|
(let* ([i (max i 0)]
|
|
[l (mline-find-paragraph (unbox line-root-box) i)])
|
|
(mline-get-line
|
|
(if l
|
|
(let loop ([l l])
|
|
(if (and (mline-next l)
|
|
(not (mline-starts-paragraph (mline-next l))))
|
|
(loop (mline-next l))
|
|
l))
|
|
last-line)))))
|
|
|
|
(def/public (last-position) len)
|
|
|
|
(public [/last-line last-line])
|
|
(define (/last-line)
|
|
(if (not (check-recalc (max-width . > . 0) #f #t))
|
|
0
|
|
(- num-valid-lines (if extra-line? 0 1))))
|
|
|
|
(def/public (last-paragraph)
|
|
(if (not (check-recalc #f #f #t))
|
|
0
|
|
(+ (mline-get-paragraph last-line) (if extra-line? 1 0))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/override (get-extent [maybe-box? w] [maybe-box? h])
|
|
(check-recalc #t #f)
|
|
(when w (set-box! w total-width))
|
|
(when h (set-box! h total-height)))
|
|
|
|
(def/override (get-descent)
|
|
(check-recalc #t #f)
|
|
final-descent)
|
|
|
|
(def/override (get-space)
|
|
(check-recalc #t #f)
|
|
initial-space)
|
|
|
|
(def/public (get-top-line-base)
|
|
(check-recalc #t #f)
|
|
initial-line-base)
|
|
|
|
(def/override (scroll-line-location [exact-nonnegative-integer? scroll])
|
|
(if read-locked?
|
|
0.0
|
|
(begin
|
|
(check-recalc #t #f)
|
|
(let ([total (+ (mline-get-scroll last-line) (mline-numscrolls last-line))])
|
|
(cond
|
|
[(= total scroll)
|
|
(if extra-line?
|
|
(- total-height extra-line-h)
|
|
total-height)]
|
|
[(scroll . > . total)
|
|
total-height]
|
|
[else
|
|
(let* ([line (mline-find-scroll (unbox line-root-box) scroll)]
|
|
[p (mline-get-scroll line)]
|
|
[y (mline-get-location line)])
|
|
(if (p . < . scroll)
|
|
(+ y (mline-scroll-offset line (- scroll p)))
|
|
y))])))))
|
|
|
|
(def/override (num-scroll-lines)
|
|
(if read-locked?
|
|
0
|
|
(begin
|
|
(check-recalc (max-width . > . 0) #f #t)
|
|
(+ (mline-get-scroll last-line)
|
|
(mline-numscrolls last-line)
|
|
(if extra-line? 1 0)))))
|
|
|
|
(def/override (find-scroll-line [real? p])
|
|
(if read-locked?
|
|
0
|
|
(begin
|
|
(check-recalc #t #f)
|
|
(if (and extra-line?
|
|
(p . >= . (- total-height extra-line-h)))
|
|
(- (num-scroll-lines) 1)
|
|
(let* ([line (mline-find-location (unbox line-root-box) p)]
|
|
[s (mline-get-scroll line)])
|
|
(if ((mline-numscrolls line) . > . 1)
|
|
(let ([y (mline-get-location line)])
|
|
(+ s (mline-find-extra-scroll line (- p y))))
|
|
s))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (find-string [string? str]
|
|
[(symbol-in forward backward) [direction 'forward]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]]
|
|
[any? [bos? #t]]
|
|
[any? [case-sens? #t]])
|
|
(if (not (check-recalc #f #f))
|
|
#f
|
|
(do-find-string-all str direction start end #t bos? case-sens?)))
|
|
|
|
(def/public (find-string-all [string? str]
|
|
[(symbol-in forward backward) [direction 'forward]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]]
|
|
[any? [bos? #t]]
|
|
[any? [case-sens? #t]])
|
|
(if (not (check-recalc #f #f))
|
|
null
|
|
(reverse (do-find-string-all str direction start end #f bos? case-sens?))))
|
|
|
|
(def/public (find-newline [(symbol-in forward backward) [direction 'forward]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]])
|
|
(let* ([para (position-paragraph (if (symbol? start)
|
|
startpos
|
|
start)
|
|
(eq? direction 'backward))]
|
|
[pos (if (eq? direction 'backward)
|
|
(paragraph-start-position para)
|
|
(if (para . >= . (last-paragraph))
|
|
len
|
|
(paragraph-start-position (add1 para))))]
|
|
[end (if (symbol? end) len end)])
|
|
(if (eq? direction 'forward)
|
|
(if (pos . > . end)
|
|
#f
|
|
pos)
|
|
(if (pos . < . end)
|
|
#f
|
|
pos))))
|
|
|
|
(define/private (do-find-string-all str direction
|
|
start end
|
|
just-one?
|
|
bos?
|
|
case-sens?)
|
|
|
|
(let ([start (min (if (symbol? start)
|
|
startpos
|
|
start)
|
|
len)]
|
|
[end (min (if (symbol? end)
|
|
(if (eq? direction 'forward)
|
|
len
|
|
0)
|
|
end)
|
|
len)])
|
|
(let ([total-count
|
|
(if (eq? direction 'backward)
|
|
(- start end)
|
|
(- end start))])
|
|
(if (or (negative? total-count)
|
|
(string=? str ""))
|
|
(if just-one? #f null)
|
|
|
|
(let ([slen (string-length str)]
|
|
[str (if case-sens?
|
|
str
|
|
(string-foldcase str))])
|
|
(let-values ([(snip s-pos) (find-snip/pos start (if (eq? direction 'forward) 'after 'before))])
|
|
|
|
(if (not snip)
|
|
(if just-one? #f null)
|
|
|
|
;; Knuth-Bendix
|
|
|
|
(let-values ([(offset shorten sbase beyond sgoal direction)
|
|
(if (eq? direction 'forward)
|
|
(values (- start s-pos) 0 0 -1 slen 1)
|
|
(values 0 (- (+ s-pos (snip->count snip)) start) (- slen 1) slen -1 -1))]
|
|
[(smap) (make-vector slen 0)])
|
|
|
|
;; initialize smap:
|
|
(vector-set! smap sbase beyond)
|
|
(let loop ([s beyond]
|
|
[i (+ sbase direction)])
|
|
(unless (= i sgoal)
|
|
(let iloop ([s s])
|
|
(if (and (not (= beyond s))
|
|
(not (char=? (string-ref str (+ s direction)) (string-ref str i))))
|
|
(iloop (vector-ref smap s))
|
|
(let ([s (if (char=? (string-ref str (+ s direction))
|
|
(string-ref str i))
|
|
(+ s direction)
|
|
s)])
|
|
(vector-set! smap i s)
|
|
(loop s (+ i direction)))))))
|
|
|
|
(let a-loop ([s beyond]
|
|
[s-pos s-pos]
|
|
[snip snip]
|
|
[total-count total-count]
|
|
[offset offset]
|
|
[shorten shorten]
|
|
[results null])
|
|
(if (and snip (positive? total-count))
|
|
(let*-values ([(need) (- (snip->count snip) shorten offset)]
|
|
[(need offset)
|
|
(if (need . > . total-count)
|
|
(if (direction . < . 0)
|
|
(values total-count (+ offset (- need total-count)))
|
|
(values total-count offset))
|
|
(values need offset))]
|
|
[(total-count) (- total-count need)])
|
|
|
|
(let b-loop ([checked 0]
|
|
[need need]
|
|
[results results])
|
|
(let* ([thistime (min need 255)]
|
|
[need (- need thistime)]
|
|
[thisoffset (+ offset (if (direction . < . 0) need checked))]
|
|
[wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
(let ([text (send snip get-text thisoffset thistime #f)])
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
|
|
(let c-loop ([i (if (direction . > . 0) 0 (- thistime 1))]
|
|
[n thistime]
|
|
[s s]
|
|
[results results])
|
|
(if (zero? n)
|
|
(if (positive? need)
|
|
|
|
(b-loop (add1 checked)
|
|
need
|
|
results)
|
|
|
|
(let* ([s-pos (if (direction . > . 0)
|
|
(+ s-pos (snip->count snip))
|
|
s-pos)]
|
|
[snip (if (direction . > . 0)
|
|
(snip->next snip)
|
|
(snip->prev snip))]
|
|
[s-pos (if (and snip (direction . < . 0))
|
|
(- s-pos (snip->count snip))
|
|
s-pos)])
|
|
(a-loop s
|
|
s-pos
|
|
snip
|
|
total-count
|
|
0
|
|
0
|
|
results)))
|
|
|
|
(let* ([n (sub1 n)]
|
|
[c (string-ref text i)]
|
|
[c (if case-sens? c (char-foldcase c))]
|
|
[s (let loop ([s s])
|
|
(if (and (not (= beyond s))
|
|
(not (char=? (string-ref str (+ s direction)) c)))
|
|
(loop (vector-ref smap s))
|
|
s))])
|
|
(if (char=? (string-ref str (+ s direction)) c)
|
|
(let ([s (+ s direction)])
|
|
(if (= (+ s direction) sgoal)
|
|
(let* ([p (+ s-pos i thisoffset)]
|
|
[p (if bos?
|
|
(if (direction . < . 0)
|
|
(+ p slen)
|
|
(- p (- slen 1)))
|
|
(if (direction . > . 0)
|
|
(add1 p)
|
|
p))])
|
|
(if just-one?
|
|
p ;; <------ single result returned here
|
|
(c-loop (+ i direction)
|
|
n
|
|
beyond
|
|
(cons p results))))
|
|
(c-loop (+ i direction)
|
|
n
|
|
s
|
|
results)))
|
|
(c-loop (+ i direction)
|
|
n
|
|
s
|
|
results)))))))))
|
|
(if just-one?
|
|
#f
|
|
results)))))))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (do-change-style start end new-style delta restore-sel? counts-as-mod?)
|
|
(assert (consistent-snip-lines 'do-change-style))
|
|
(unless (or write-locked?
|
|
s-user-locked?
|
|
(and new-style
|
|
(not (send s-style-list style-to-index new-style))))
|
|
(let* ([start (max 0 (min len start))]
|
|
[end (min end len)])
|
|
(unless (start . > . end)
|
|
(let ([new-style (if (and (not new-style) (not delta))
|
|
(or (get-default-style)
|
|
(send s-style-list basic-style))
|
|
new-style)])
|
|
(cond
|
|
[(and (= start startpos) (= end endpos) (= end start) (positive? len))
|
|
(when sticky-styles?
|
|
(set! caret-style
|
|
(cond
|
|
[new-style new-style]
|
|
[caret-style (send s-style-list find-or-create-style caret-style delta)]
|
|
[else (let ([gsnip (do-find-snip start 'before)])
|
|
(send s-style-list find-or-create-style (snip->style gsnip) delta))])))]
|
|
[else
|
|
(set! write-locked? #t)
|
|
|
|
(if (not (can-change-style? start (- end start)))
|
|
(set! write-locked? #f)
|
|
|
|
(begin
|
|
(on-change-style start (- end start))
|
|
|
|
(set! flow-locked? #t)
|
|
|
|
(make-snipset start end)
|
|
|
|
(let-values ([(start-snip end-snip)
|
|
(if (zero? len)
|
|
(begin
|
|
(set! initial-style-needed? #f)
|
|
(values snips #f))
|
|
(values (do-find-snip start 'after) (do-find-snip end 'after-or-none)))]
|
|
[(rec)
|
|
(and (zero? s-noundomode)
|
|
(make-object style-change-record% start end
|
|
(or delayed-streak? (not s-modified?))
|
|
startpos endpos restore-sel?))])
|
|
(let loop ([something? #f]
|
|
[extra-check-pos #f]
|
|
[prev-style #f]
|
|
[prev-style-pos start]
|
|
[p start]
|
|
[gsnip start-snip])
|
|
(if (not (eq? gsnip end-snip))
|
|
;; Change a snip style:
|
|
(let* ([style (snip->style gsnip)]
|
|
[style2 (or new-style
|
|
(send s-style-list find-or-create-style style delta))])
|
|
(if (not (eq? style style2))
|
|
(begin
|
|
(set-snip-style! gsnip style2)
|
|
(let-values ([(prev-style prev-style-pos)
|
|
(if (and rec (not (eq? prev-style style)))
|
|
(begin
|
|
(when prev-style
|
|
(send rec add-style-change prev-style-pos p prev-style))
|
|
(values style p))
|
|
(values prev-style prev-style-pos))])
|
|
(send gsnip size-cache-invalid)
|
|
(mline-mark-recalculate (snip->line gsnip))
|
|
(when (max-width . > . 0)
|
|
(mline-mark-check-flow (snip->line gsnip)))
|
|
(loop #t
|
|
p
|
|
prev-style
|
|
prev-style-pos
|
|
(+ p (snip->count gsnip))
|
|
(snip->next gsnip))))
|
|
(let ([prev-style
|
|
(if (and rec prev-style)
|
|
(begin
|
|
(send rec add-style-change prev-style-pos p prev-style)
|
|
#f)
|
|
prev-style)])
|
|
(loop something?
|
|
extra-check-pos
|
|
prev-style
|
|
prev-style-pos
|
|
(+ p (snip->count gsnip))
|
|
(snip->next gsnip)))))
|
|
;; All snips changed
|
|
(begin
|
|
(when (and rec prev-style)
|
|
(send rec add-style-change prev-style-pos p prev-style))
|
|
|
|
(if something?
|
|
;; Something changed, so recalc and refresh:
|
|
(let ([line (snip->line start-snip)])
|
|
(when (and (mline-prev line)
|
|
(not (has-flag? (snip->flags (mline-snip (mline-prev line))) HARD-NEWLINE)))
|
|
(mline-mark-check-flow (mline-prev line)))
|
|
(when (not s-modified?)
|
|
(add-undo-rec (make-object unmodify-record% delayed-streak?)))
|
|
(when rec
|
|
(add-undo-rec rec))
|
|
(when (positive? delay-refresh)
|
|
(set! delayed-streak? #t))
|
|
|
|
(check-merge-snips start)
|
|
(when extra-check-pos
|
|
(check-merge-snips extra-check-pos))
|
|
(when (not (= end extra-check-pos))
|
|
(check-merge-snips end))
|
|
|
|
(when (and (not s-modified?) counts-as-mod?)
|
|
(set-modified #t))
|
|
|
|
(set! write-locked? #f)
|
|
(set! flow-locked? #f)
|
|
|
|
(refresh-by-line-demand))
|
|
;; Nothing changed after all:
|
|
(begin
|
|
(set! write-locked? #f)
|
|
(set! flow-locked? #f)
|
|
|
|
(check-merge-snips start)
|
|
(check-merge-snips end)))
|
|
|
|
(after-change-style start (- end start))))))))]))))
|
|
(assert (consistent-snip-lines 'post-do-change-style))))
|
|
|
|
(def/public (change-style [(make-or-false (make-alts style<%> style-delta%)) st]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
|
|
[(make-alts exact-nonnegative-integer? (symbol-in end)) [end 'end]]
|
|
[any? [counts-as-mod? #t]])
|
|
(do-change-style (if (symbol? start) startpos start)
|
|
(if (symbol? end) (if (symbol? start) endpos len) end)
|
|
(and (st . is-a? . style<%>) st)
|
|
(and (st . is-a? . style-delta%) st)
|
|
1
|
|
counts-as-mod?))
|
|
|
|
(def/override (set-style-list [style-list% new-list])
|
|
(unless write-locked?
|
|
(let ([delta (new style-delta%)]
|
|
[count (send s-style-list number)])
|
|
(when (positive? count)
|
|
(let ([smap (make-vector count #f)])
|
|
(vector-set! smap 0 (send new-list index-to-style 0))
|
|
(for ([index (in-range 1 count)])
|
|
(let* ([style (send s-style-list index-to-style index)]
|
|
[name (send style get-name)])
|
|
(vector-set!
|
|
smap
|
|
index
|
|
(cond
|
|
[(and name (send new-list find-named-style name))
|
|
=> (lambda (new-style) new-style)]
|
|
[else
|
|
(let ([new-style
|
|
(let* ([base-style (send style get-base-style)]
|
|
[base-index (send s-style-list style-to-index base-style)])
|
|
(if (send style is-join?)
|
|
(let* ([ss (send style get-shift-style)]
|
|
[shift-index (send s-style-list style-to-index ss)])
|
|
(send new-list find-or-create-join-style
|
|
(vector-ref smap base-index)
|
|
(vector-ref smap shift-index)))
|
|
(begin
|
|
(send style get-delta delta)
|
|
(send new-list find-or-create-style
|
|
(vector-ref smap base-index)
|
|
delta))))])
|
|
(if name
|
|
(send new-list new-named-style name new-style)
|
|
new-style))]))))
|
|
(let loop ([snip snips])
|
|
(when snip
|
|
(let* ([index (send s-style-list style-to-index (snip->style snip))]
|
|
[index (if (not index)
|
|
;; bad! snip had style not from this buffer's style list
|
|
0
|
|
index)])
|
|
(set-snip-style! snip (vector-ref smap index)))
|
|
(loop (snip->next snip))))))
|
|
|
|
(super set-style-list new-list)
|
|
|
|
(size-cache-invalid)
|
|
(set! changed? #t)
|
|
(need-refresh -1 -1))))
|
|
|
|
(def/override (style-has-changed [(make-or-false style<%>) style])
|
|
(unless read-locked?
|
|
(if (not style)
|
|
;; our cue to repaint
|
|
(begin
|
|
(set! changed? #t)
|
|
(need-refresh -1 -1))
|
|
;; notify snips:
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let loop ([snip snips])
|
|
(when snip
|
|
(when (eq? style (snip->style snip))
|
|
(send snip size-cache-invalid)
|
|
(let ([line (snip->line snip)])
|
|
(mline-mark-recalculate line)
|
|
(when (max-width . >= . 0)
|
|
(mline-mark-check-flow line)
|
|
(when (and (mline-prev line)
|
|
(not (has-flag? (snip->flags (mline-last-snip (mline-prev line)))
|
|
HARD-NEWLINE)))
|
|
(mline-mark-check-flow (mline-prev line))))))
|
|
(loop (snip->next snip))))
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (do-scroll-to snip localx localy w h refresh? [bias 'none])
|
|
(cond
|
|
[flow-locked? #f]
|
|
[(positive? delay-refresh)
|
|
(when s-admin
|
|
(set! delayedscroll -1)
|
|
(set! delayedscrollbox? #t)
|
|
(set! delayedscrollsnip snip)
|
|
(set! delayedscroll-x localx)
|
|
(set! delayedscroll-y localy)
|
|
(set! delayedscroll-w w)
|
|
(set! delayedscroll-h h)
|
|
(set! delayedscrollbias bias))
|
|
#f]
|
|
[else
|
|
(let-boxes ([x 0.0]
|
|
[y 0.0]
|
|
[ok? #t])
|
|
(when snip
|
|
(set-box! ok? (get-snip-position-and-location snip #f x y)))
|
|
(cond
|
|
[(not ok?) #f]
|
|
[(scroll-editor-to (+ x localx) (+ y localy) w h refresh? bias)
|
|
(unless refresh?
|
|
(set! refresh-all? #t))
|
|
#t]
|
|
[else #f]))]))
|
|
|
|
(def/public (scroll-to [snip% snip] [real? localx] [real? localy]
|
|
[nonnegative-real? w] [nonnegative-real? h]
|
|
[any? refresh?]
|
|
[(symbol-in start end none) [bias 'none]])
|
|
(do-scroll-to snip localx localy w h refresh? bias))
|
|
|
|
(def/override (resized [snip% snip] [any? redraw-now?])
|
|
(when (get-snip-position-and-location snip #f #f #f)
|
|
|
|
(let ([line (snip->line snip)])
|
|
(mline-mark-recalculate line)
|
|
(when (max-width . >= . 0)
|
|
(mline-mark-check-flow line)
|
|
;; maybe something can now move to the previous line
|
|
(when (and (mline-prev line)
|
|
(not (has-flag? (snip->flags (mline-last-snip (mline-prev line)))
|
|
HARD-NEWLINE)))
|
|
(mline-mark-check-flow (mline-prev line)))))
|
|
|
|
(set! graphic-maybe-invalid? #t)
|
|
|
|
(let ([redraw-now? (and redraw-now?
|
|
(not flow-locked?))])
|
|
|
|
(set! changed? #t)
|
|
|
|
(unless redraw-now? (set! delay-refresh (add1 delay-refresh)))
|
|
(refresh-by-line-demand)
|
|
(unless redraw-now? (set! delay-refresh (sub1 delay-refresh))))))
|
|
|
|
(def/override (recounted [snip% snip] [any? redraw-now?])
|
|
(if write-locked?
|
|
#f
|
|
(begin
|
|
(set! revision-count (add1 revision-count))
|
|
(resized snip redraw-now?)
|
|
#t)))
|
|
|
|
(def/override (set-caret-owner [(make-or-false snip%) snip]
|
|
[(symbol-in immediate display global) [dist 'immediate]])
|
|
(when (do-set-caret-owner snip dist)
|
|
(need-refresh startpos endpos) ;; (need-caret-refresh); <- doesn't work; local caret ownership weirdness
|
|
(on-focus (not snip))))
|
|
|
|
(def/override (release-snip [snip% snip])
|
|
(let ([pos (get-snip-position snip)])
|
|
(and pos
|
|
(begin
|
|
(do-delete pos (+ pos (snip->count snip)) #f #f)
|
|
(when (and (not (snip->admin snip))
|
|
(has-flag? (snip->flags snip) OWNED))
|
|
(set-snip-flags! snip (remove-flag (snip->flags snip) OWNED)))
|
|
#t))))
|
|
|
|
(define/public (refresh-box L T w h)
|
|
(let ([B (+ T h)]
|
|
[R (+ L w)])
|
|
(if refresh-box-unset?
|
|
(begin
|
|
(set! refresh-l L)
|
|
(set! refresh-r R)
|
|
(set! refresh-t T)
|
|
(set! refresh-b B)
|
|
(set! refresh-box-unset? #f))
|
|
(begin
|
|
(when (L . < . refresh-l)
|
|
(set! refresh-l L))
|
|
(when (R . > . refresh-r)
|
|
(set! refresh-r R))
|
|
(when (T . < . refresh-t)
|
|
(set! refresh-t T))
|
|
(when (B . > . refresh-b)
|
|
(set! refresh-b B))))
|
|
|
|
(set! draw-cached-in-bitmap? #f)))
|
|
|
|
(def/override (needs-update [snip% snip]
|
|
[real? localx] [real? localy]
|
|
[nonnegative-real? w] [nonnegative-real? h])
|
|
(let-boxes ([x 0.0]
|
|
[y 0.0]
|
|
[ok? #t])
|
|
(set-box! ok? (get-snip-location snip x y))
|
|
(when ok?
|
|
(refresh-box (+ x localx) (+ y localy) w h)
|
|
(when (zero? delay-refresh)
|
|
(redraw)))))
|
|
|
|
(def/override (invalidate-bitmap-cache [real? [x 0.0]]
|
|
[real? [y 0.0]]
|
|
[(make-alts nonnegative-real? (symbol-in end)) [w 'end]]
|
|
[(make-alts nonnegative-real? (symbol-in end)) [h 'end]])
|
|
(let ([w (if (symbol? w) (- total-width x) w)]
|
|
[h (if (symbol? h) (- total-height y) h)])
|
|
|
|
(refresh-box x y w h)
|
|
(when (zero? delay-refresh)
|
|
(redraw))))
|
|
|
|
(def/public (hide-caret [any? hide?])
|
|
(unless (eq? hilite-on? (not hide?))
|
|
(set! hilite-on? (not hide?))
|
|
(when (or s-own-caret? (not (= endpos startpos)))
|
|
(need-caret-refresh))))
|
|
|
|
(def/public (caret-hidden?) (not hilite-on?))
|
|
|
|
(def/public (get-between-threshold) between-threshold)
|
|
|
|
(def/public (set-between-threshold [nonnegative-real? t])
|
|
(set! between-threshold (min t 99.0)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (make-only-snip)
|
|
(set! snips (new string-snip%))
|
|
(set-snip-style! snips (or (get-default-style)
|
|
(send s-style-list basic-style)))
|
|
(set-snip-count! snips 0)
|
|
(send snips set-s-admin snip-admin)
|
|
|
|
(let ([line (create-mline)])
|
|
(set-snip-line! snips line)
|
|
(set-box! line-root-box line)
|
|
(set! first-line line)
|
|
(set! last-line line)
|
|
(mline-set-starts-paragraph line #t)
|
|
|
|
(set-mline-snip! line snips)
|
|
(set-mline-last-snip! line snips)
|
|
|
|
(set! last-snip snips)
|
|
(set! snip-count 1)
|
|
|
|
(set! num-valid-lines 1)))
|
|
|
|
(define/private (splice-snip snip prev next)
|
|
(if prev
|
|
(set-snip-next! prev snip)
|
|
(set! snips snip))
|
|
(set-snip-prev! snip prev)
|
|
(set-snip-next! snip next)
|
|
(if next
|
|
(set-snip-prev! next snip)
|
|
(set! last-snip snip)))
|
|
|
|
(define/private (insert-snip before snip)
|
|
(if (and (eq? snips last-snip) (zero? (snip->count snips)))
|
|
(append-snip snip)
|
|
(begin
|
|
(splice-snip snip (snip->prev before) before)
|
|
(set! snip-count (add1 snip-count)))))
|
|
|
|
(define/private (append-snip snip)
|
|
(if (and (eq? snips last-snip) (zero? (snip->count snips)))
|
|
;; get rid of empty snip
|
|
(begin
|
|
(set! snips snip)
|
|
(set! last-snip snip))
|
|
(begin
|
|
(splice-snip snip last-snip #f)
|
|
(set! snip-count (add1 snip-count)))))
|
|
|
|
(define/private (delete-snip snip)
|
|
(cond
|
|
[(snip->next snip)
|
|
(splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))]
|
|
[(snip->prev snip)
|
|
(splice-snip (snip->prev snip) (snip->prev (snip->prev snip)) (snip->next snip))]
|
|
[else
|
|
(set! last-snip #f)
|
|
(set! snips #f)])
|
|
(set! snip-count (sub1 snip-count))
|
|
(set-snip-flags! snip (add-flag (snip->flags snip) CAN-DISOWN))
|
|
(snip-set-admin snip #f)
|
|
(set-snip-line! snip #f)
|
|
(set-snip-prev! snip #f)
|
|
(set-snip-next! snip #f)
|
|
(set-snip-flags! snip (remove-flag (snip->flags snip) CAN-DISOWN)))
|
|
|
|
(define/private (snip-set-admin snip a)
|
|
(let ([orig-count (snip->count snip)]
|
|
[line (snip->line snip)]
|
|
[orig-admin (snip->admin snip)]
|
|
[wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
|
|
(set! read-locked? #t)
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(send snip set-admin a)
|
|
|
|
(set! read-locked? #f)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
|
|
(let ([snip
|
|
(if (not (eq? (snip->admin snip) a))
|
|
;; something went wrong
|
|
(cond
|
|
[(and (not a) (eq? (snip->admin snip) orig-admin))
|
|
;; force admin to NULL
|
|
(send snip set-s-admin #f)
|
|
snip]
|
|
[a
|
|
;; snip didn't accept membership into this editor; give up on it
|
|
(let ([naya (new snip%)])
|
|
(set-snip-count! naya orig-count)
|
|
(splice-snip naya (snip->prev snip) (snip->next snip))
|
|
(set-snip-line! naya line)
|
|
|
|
(when line
|
|
(when (eq? (mline-snip line) snip)
|
|
(set-mline-snip! line naya))
|
|
(when (eq? (mline-last-snip line) snip)
|
|
(set-mline-last-snip! line naya)))
|
|
|
|
(send snip set-s-admin #f)
|
|
|
|
(send naya set-admin a)
|
|
(set! snip naya)
|
|
naya)]
|
|
[else snip])
|
|
snip)])
|
|
|
|
;; force count to be consistent:
|
|
(when (and a (not (= (snip->count snip) orig-count)))
|
|
(set-snip-count! snip orig-count))
|
|
|
|
snip)))
|
|
|
|
(define/private (snip-split snip pos a-ptr b-ptr)
|
|
(let ([c (snip->count snip)]
|
|
[nl? (has-flag? (snip->flags snip) NEWLINE)]
|
|
[hnl? (has-flag? (snip->flags snip) HARD-NEWLINE)]
|
|
[orig snip])
|
|
|
|
(set-snip-flags! snip (add-flag (snip->flags snip) CAN-SPLIT))
|
|
|
|
(delete-snip snip)
|
|
|
|
(set-snip-flags! orig (remove-flag (snip->flags orig) OWNED))
|
|
|
|
(set! revision-count (add1 revision-count))
|
|
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
|
|
(set! read-locked? #t)
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(send snip split pos a-ptr b-ptr)
|
|
|
|
(set! read-locked? #f)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?))
|
|
|
|
(let* ([a (or (unbox a-ptr)
|
|
(new snip%))]
|
|
[a (if (send a is-owned?)
|
|
(new snip%)
|
|
a)]
|
|
[b (or (unbox b-ptr)
|
|
(new snip%))]
|
|
[b (if (send b is-owned?)
|
|
(new snip%)
|
|
b)])
|
|
|
|
(set-box! a-ptr a)
|
|
(set-box! b-ptr b)
|
|
|
|
(set-snip-flags! a (remove-flag (snip->flags a) CAN-SPLIT))
|
|
(set-snip-flags! b (remove-flag (snip->flags b) CAN-SPLIT))
|
|
(set-snip-flags! orig (remove-flag (snip->flags orig) CAN-SPLIT))
|
|
|
|
;; make sure that count is right
|
|
(set-snip-count! a pos)
|
|
(set-snip-count! b (- c pos))
|
|
|
|
;; make sure that NEWLINE & HARD-NEWLINE is consistent:
|
|
(when nl?
|
|
(set-snip-flags! b (add-flag (snip->flags b) NEWLINE)))
|
|
(when hnl?
|
|
(set-snip-flags! b (add-flag (snip->flags b) HARD-NEWLINE)))
|
|
(set-snip-flags! a (remove-flag (remove-flag (snip->flags b) NEWLINE)
|
|
HARD-NEWLINE)))))
|
|
|
|
(define/private (split-one pos s-pos snip extra)
|
|
(let ([line (snip->line snip)]
|
|
[prev (snip->prev snip)]
|
|
[next (snip->next snip)]
|
|
[style (snip->style snip)])
|
|
(let ([at-start? (eq? (mline-snip line) snip)]
|
|
[at-end? (eq? (mline-last-snip line) snip)]
|
|
[orig snip])
|
|
(let-boxes ([ins-snip #f]
|
|
[snip #f])
|
|
(snip-split orig (- pos s-pos) ins-snip snip)
|
|
|
|
(set-snip-style! snip style)
|
|
(set-snip-style! ins-snip style)
|
|
|
|
(set-snip-line! snip line)
|
|
(set-snip-line! ins-snip line)
|
|
|
|
(when at-start?
|
|
(set-mline-snip! line ins-snip))
|
|
(when at-end?
|
|
(set-mline-last-snip! line snip))
|
|
|
|
(splice-snip snip prev next)
|
|
(set! snip-count (add1 snip-count))
|
|
(insert-snip snip ins-snip)
|
|
(when extra
|
|
(extra snip))
|
|
|
|
(snip-set-admin snip snip-admin)
|
|
(snip-set-admin ins-snip snip-admin)
|
|
|
|
(after-split-snip (- pos s-pos))))))
|
|
|
|
(define/private (make-snipset start end)
|
|
;; BEWARE: `len' may not be up-to-date
|
|
(when (positive? start)
|
|
(let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)])
|
|
(when snip
|
|
(unless (= s-pos start)
|
|
(split-one start s-pos snip #f)))))
|
|
(when (positive? end)
|
|
(let-values ([(snip s-pos) (find-snip/pos end 'before)])
|
|
(unless (= (+ s-pos (snip->count snip)) end)
|
|
(split-one end s-pos snip #f)))))
|
|
|
|
(define/private (insert-text-snip start style)
|
|
(let* ([snip (on-new-string-snip)]
|
|
[snip (if (or (send snip is-owned?)
|
|
(positive? (snip->count snip)))
|
|
;; uh-oh; resort to string-snip%
|
|
(new string-snip%)
|
|
snip)]
|
|
[style (or style
|
|
(get-default-style)
|
|
(send s-style-list basic-style))])
|
|
(set-snip-style! snip style)
|
|
(let ([snip (let ([rsnip (snip-set-admin snip snip-admin)])
|
|
(if (not (eq? snip rsnip))
|
|
;; uh-oh; resort to string-snip%:
|
|
(let ([snip (new string-snip%)])
|
|
(set-snip-style! snip style)
|
|
(send snip set-s-admin snip-admin))
|
|
snip))])
|
|
(set-snip-count! snip 0)
|
|
|
|
(let-values ([(gsnip s-pos) (find-snip/pos start 'before-or-none)])
|
|
(if (and gsnip
|
|
(= (+ (snip->count gsnip) s-pos) start)
|
|
(has-flag? (snip->flags gsnip) NEWLINE)
|
|
(not (has-flag? (snip->flags gsnip) HARD-NEWLINE)))
|
|
(begin
|
|
;; we want the snip on the same line as the preceding snip:
|
|
(if (snip->next gsnip)
|
|
(insert-snip (snip->next gsnip) snip)
|
|
(append-snip snip))
|
|
(set-snip-flags! gsnip (remove-flag (snip->flags gsnip) NEWLINE))
|
|
(set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE))
|
|
(set-snip-line! snip (snip->line gsnip))
|
|
(set-mline-last-snip! (snip->line snip) snip)
|
|
snip)
|
|
(let-values ([(gsnip s-pos) (find-snip/pos start 'after-or-none)])
|
|
(cond
|
|
[(not gsnip)
|
|
(append-snip snip)
|
|
(set-snip-line! snip last-line)
|
|
(when (eq? (mline-last-snip last-line) last-snip)
|
|
(set! last-snip snip))
|
|
(set-mline-last-snip! last-line snip)
|
|
snip]
|
|
[(= s-pos start)
|
|
(insert-snip gsnip snip)
|
|
(set-snip-line! snip (snip->line gsnip))
|
|
(when (eq? (mline-snip (snip->line snip)) gsnip)
|
|
(set-mline-snip! (snip->line snip) snip))
|
|
snip]
|
|
[else
|
|
(split-one start s-pos gsnip
|
|
(lambda (gsnip)
|
|
(set-snip-line! snip (snip->line gsnip))
|
|
(insert-snip gsnip snip)))
|
|
snip])))))))
|
|
|
|
(define/private (check-merge-snips start)
|
|
(when (let loop ([did-something? #f])
|
|
(let-values ([(snip1 s-pos1) (find-snip/pos start 'before)]
|
|
[(snip2 s-pos2) (find-snip/pos start 'after)])
|
|
(if (eq? snip1 snip2)
|
|
did-something?
|
|
(if (not (and (snip->snipclass snip1)
|
|
(eq? (snip->snipclass snip1) (snip->snipclass snip2))
|
|
(eq? (snip->style snip1) (snip->style snip2))))
|
|
did-something?
|
|
(if (not (and
|
|
(not (has-flag? (snip->flags snip1) NEWLINE))
|
|
(has-flag? (snip->flags snip1) CAN-APPEND)
|
|
(has-flag? (snip->flags snip2) CAN-APPEND)
|
|
((+ (snip->count snip1) (snip->count snip2)) . < . MAX-COUNT-FOR-SNIP)
|
|
(eq? (snip->line snip1) (snip->line snip2))))
|
|
did-something?
|
|
(cond
|
|
[(zero? (snip->count snip1))
|
|
(when (eq? (mline-snip (snip->line snip1)) snip1)
|
|
(set-mline-snip! (snip->line snip1) snip2))
|
|
(delete-snip snip1)
|
|
(set-snip-flags! snip1 (remove-flag (snip->flags snip1) OWNED))
|
|
(loop #t)]
|
|
[(zero? (snip->count snip2))
|
|
(when (eq? (mline-last-snip (snip->line snip2)) snip2)
|
|
(set-mline-last-snip! (snip->line snip2) snip1)
|
|
(mline-mark-recalculate (snip->line snip1)) ; need last-w updated
|
|
(set! graphic-maybe-invalid? #t))
|
|
(delete-snip snip2)
|
|
(set-snip-flags! snip2 (remove-flag (snip->flags snip2) OWNED))
|
|
(loop #t)]
|
|
[else
|
|
(let ([c (+ (snip->count snip1) (snip->count snip2))]
|
|
[prev (snip->prev snip1)]
|
|
[next (snip->next snip2)]
|
|
[line (snip->line snip1)])
|
|
(let ([at-start? (eq? (mline-snip line) snip1)]
|
|
[at-end? (eq? (mline-last-snip line) snip2)]
|
|
[wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! read-locked? #t)
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(set-snip-flags! snip2 (add-flag (snip->flags snip2) CAN-SPLIT))
|
|
(let ([naya (send snip2 merge-with snip1)])
|
|
(set! read-locked? #f)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)
|
|
|
|
(if naya
|
|
(begin
|
|
;; claim snip1 & snip2 unowned for naya test:
|
|
(set-snip-flags! snip1 (remove-flag (remove-flag (snip->flags snip1) CAN-SPLIT)
|
|
OWNED))
|
|
(set-snip-flags! snip2 (remove-flag (remove-flag (snip->flags snip2) CAN-SPLIT)
|
|
OWNED))
|
|
|
|
(let ([naya (if (send naya is-owned?)
|
|
;; uh-oh; make dummy
|
|
(new snip%)
|
|
naya)])
|
|
(set-snip-flags! naya (remove-flag (snip->flags naya) CAN-SPLIT))
|
|
(set-snip-flags! snip1 (add-flag (snip->flags snip1) OWNED))
|
|
(set-snip-flags! snip2 (add-flag (snip->flags snip2) OWNED))
|
|
|
|
(delete-snip snip1)
|
|
(set-snip-flags! snip1 (remove-flag (snip->flags snip1) OWNED))
|
|
(delete-snip snip2)
|
|
(set-snip-flags! snip2 (remove-flag (snip->flags snip2) OWNED))
|
|
|
|
(splice-snip naya prev next)
|
|
(set! snip-count (add1 snip-count))
|
|
|
|
;; make sure that count is right:
|
|
(set-snip-count! naya c)
|
|
|
|
(set! revision-count (add1 revision-count))
|
|
|
|
(let ([naya (snip-set-admin naya snip-admin)])
|
|
|
|
(set-snip-line! naya line)
|
|
(when at-start?
|
|
(set-mline-snip! line naya))
|
|
(when at-end?
|
|
(set-mline-last-snip! line naya)
|
|
(mline-mark-recalculate line) ;; need last-w updated
|
|
(set! graphic-maybe-invalid? #t))
|
|
#t)))
|
|
(begin
|
|
(set-snip-flags! snip2 (remove-flag (snip->flags snip2) CAN-SPLIT))
|
|
#t)))))]))))))
|
|
(after-merge-snips start)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (on-new-string-snip)
|
|
(new string-snip%))
|
|
|
|
(def/public (on-new-tab-snip)
|
|
(new tab-snip%))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/override (find-first-snip)
|
|
(if (zero? len)
|
|
#f
|
|
snips))
|
|
|
|
(define/private (do-find-snip p direction)
|
|
;; BEWARE: `len' may not be up-to-date
|
|
(let-values ([(snip pos) (find-snip/pos p direction)])
|
|
snip))
|
|
|
|
(def/public (find-snip [exact-nonnegative-integer? p]
|
|
[(symbol-in before-or-none before after after-or-none) direction]
|
|
[maybe-box? [s-pos #f]])
|
|
;; BEWARE: `len' may not be up-to-date
|
|
(let-values ([(snip pos) (find-snip/pos p direction)])
|
|
(when s-pos (set-box! s-pos pos))
|
|
snip))
|
|
|
|
(define/private (find-snip/pos p direction)
|
|
;; BEWARE: `len' may not be up-to-date
|
|
(cond
|
|
[(and (eq? direction 'before-or-none) (zero? p))
|
|
(values #f 0)]
|
|
[else
|
|
(let* ([line (mline-find-position (unbox line-root-box) p)]
|
|
[pos (mline-get-position line)]
|
|
[p (- p pos)])
|
|
(if (and (eq? direction 'after-or-none)
|
|
(not (mline-next line))
|
|
(p . >= . (mline-len line)))
|
|
;; past the end:
|
|
(values #f 0)
|
|
;; within the line:
|
|
(let-values ([(snip pos p)
|
|
(let ([snip (mline-snip line)])
|
|
(if (and (zero? p) (snip->prev snip))
|
|
;; back up one:
|
|
(let ([snip (snip->prev snip)])
|
|
(values snip
|
|
(- pos (snip->count snip))
|
|
(+ p (snip->count snip))))
|
|
(values snip pos p)))])
|
|
|
|
(let loop ([snip snip]
|
|
[pos pos]
|
|
[p p])
|
|
(if snip
|
|
(let ([p (- p (snip->count snip))])
|
|
(cond
|
|
[(or (and (eq? direction 'on)
|
|
(zero? p))
|
|
(and (or (eq? direction 'before)
|
|
(eq? direction 'before-or-none))
|
|
(p . <= . 0))
|
|
(and (or (eq? direction 'after)
|
|
(eq? direction 'after-or-none))
|
|
(p . < . 0)))
|
|
(values snip pos)]
|
|
[(and (eq? direction 'on)
|
|
(p . < . 0))
|
|
(values #f 0)]
|
|
[else
|
|
(loop (snip->next snip) (+ pos (snip->count snip)) p)]))
|
|
(if (not (eq? direction 'after-or-none))
|
|
(values last-snip (- pos (snip->count last-snip)))
|
|
(values #f 0)))))))]))
|
|
|
|
(def/public (find-next-non-string-snip [(make-or-false snip%) snip])
|
|
(if (or (and snip
|
|
(not (eq? (snip->admin snip) snip-admin)))
|
|
(zero? len))
|
|
#f
|
|
(let loop ([snip (if snip
|
|
(snip->next snip)
|
|
snips)])
|
|
(if (and snip (snip . is-a? . string-snip%))
|
|
(loop (snip->next snip))
|
|
snip))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/override (setting-admin admin) (void))
|
|
|
|
(define/override (init-new-admin)
|
|
(when (and (zero? delay-refresh)
|
|
(or (not s-admin) (not (send s-admin refresh-delayed?))))
|
|
(redraw)))
|
|
|
|
(define/private (end-streaks exceptions)
|
|
(when (and s-keymap
|
|
(not (memq 'key-sequence exceptions))
|
|
(not streaks-pushed?))
|
|
(send s-keymap break-sequence))
|
|
(when (and flash? flashautoreset? (not flashdirectoff?))
|
|
(flash-off))
|
|
|
|
(set! typing-streak? #f)
|
|
(set! deletion-streak? #f)
|
|
(when (not (memq 'cursor exceptions))
|
|
(set! vcursor-streak? #f)
|
|
(set! extend-streak? #f))
|
|
|
|
(when (and anchor-streak? (not keep-anchor-streak?))
|
|
(set-anchor #f))
|
|
|
|
(when (not (memq 'delayed exceptions))
|
|
(set! delayed-streak? #f))
|
|
|
|
(set! kill-streak? #f)
|
|
|
|
(set! prev-paste-start -1))
|
|
|
|
(define/private (push-streaks)
|
|
(set! streaks-pushed? #t)
|
|
(set! save-typing-streak? typing-streak?)
|
|
(set! save-deletion-streak? deletion-streak?)
|
|
(set! save-delayed-streak? delayed-streak?)
|
|
(set! save-vcursor-streak? vcursor-streak?)
|
|
(set! save-kill-streak? kill-streak?)
|
|
(set! save-anchor-streak? anchor-streak?)
|
|
(set! save-extend-streak? extend-streak?)
|
|
(set! save-prev-paste-start prev-paste-start)
|
|
(set! save-prev-paste-end prev-paste-end))
|
|
|
|
(define/private (pop-streaks)
|
|
(when streaks-pushed?
|
|
(set! streaks-pushed? #f)
|
|
(set! typing-streak? save-typing-streak?)
|
|
(set! deletion-streak? save-deletion-streak?)
|
|
(set! delayed-streak? save-delayed-streak?)
|
|
(set! vcursor-streak? save-vcursor-streak?)
|
|
(set! kill-streak? save-kill-streak?)
|
|
(set! anchor-streak? save-anchor-streak?)
|
|
(set! extend-streak? save-extend-streak?)
|
|
(set! prev-paste-start save-prev-paste-start)
|
|
(set! prev-paste-end save-prev-paste-end)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (check-recalc [need-graphic? #t] [need-write? #t] [no-display-ok? #f])
|
|
(and (not read-locked?)
|
|
(not (and write-locked? need-write?))
|
|
(if (not need-graphic?)
|
|
#t
|
|
(if (not s-admin)
|
|
no-display-ok?
|
|
(if (not graphic-maybe-invalid?)
|
|
#t
|
|
(if flow-locked?
|
|
#f
|
|
(let ([dc (send s-admin get-dc)])
|
|
(if (not dc)
|
|
no-display-ok?
|
|
(recalc-lines dc need-graphic?)))))))))
|
|
|
|
(define/public (check-flow maxw dc Y startp start)
|
|
;; this method is called with write-locked and flow-locked already #t
|
|
(let ([p startp]
|
|
[checking-underflow? #f] ;; start by ensuring no overflow
|
|
[checking-underflow-at-next? #f]
|
|
[no-change-if-end-of-snip? #t] ;; because an immediate overflow can't be helped
|
|
[no-change-if-start-of-snip? #f]
|
|
[the-first-snip? #t]
|
|
[first-underflow? #f]
|
|
[deleted-a-newline? #f]
|
|
[had-newline? #f])
|
|
|
|
(define (done snip)
|
|
(cond
|
|
[(and (not snip)
|
|
(has-flag? (snip->flags last-snip) NEWLINE)
|
|
(not (has-flag? (snip->flags last-snip) HARD-NEWLINE)))
|
|
(begin
|
|
(set-snip-flags! last-snip (remove-flag (snip->flags last-snip) NEWLINE))
|
|
(set! refresh-all? #t)
|
|
#t)]
|
|
[(or (not checking-underflow?) no-change-if-end-of-snip?)
|
|
deleted-a-newline?]
|
|
[else
|
|
(set! refresh-all? #t)
|
|
#t]))
|
|
|
|
(let loop ([snip start]
|
|
[p p]
|
|
[_total-width 0])
|
|
(if (and snip (not (has-flag? (snip->flags snip) HARD-NEWLINE)))
|
|
(begin
|
|
(when (not checking-underflow?)
|
|
(set! checking-underflow? checking-underflow-at-next?)
|
|
(when checking-underflow?
|
|
(set! first-underflow? #t)))
|
|
(set! no-change-if-start-of-snip? no-change-if-end-of-snip?)
|
|
|
|
(if (has-flag? (snip->flags snip) NEWLINE)
|
|
(begin
|
|
(set! no-change-if-end-of-snip? (not checking-underflow?))
|
|
(set-snip-flags! snip (remove-flag (snip->flags snip) NEWLINE))
|
|
(set! checking-underflow-at-next? #t)
|
|
(set! had-newline? #t)
|
|
(set! deleted-a-newline? #t)
|
|
;; note: if the newline is restored, then
|
|
;; we leave the loop
|
|
)
|
|
(begin
|
|
(set! no-change-if-end-of-snip? #f)
|
|
(set! checking-underflow-at-next? #f)
|
|
(set! had-newline? #f)))
|
|
|
|
(let-boxes ([w 0.0])
|
|
(send snip get-extent dc _total-width Y w #f #f #f #f #f)
|
|
(let ([_total-width (+ _total-width w)])
|
|
(if (_total-width . > . maxw)
|
|
(let ([_total-width (- _total-width w)])
|
|
;; get best breaking position:
|
|
;; (0.1 is hopefully a positive value smaller than any character)
|
|
(let ([origc (do-find-position-in-snip dc _total-width Y snip (- maxw _total-width 0.1) #f)])
|
|
;; get legal breaking position before optimal:
|
|
(let-boxes ([b (+ p origc 1)])
|
|
(find-wordbreak b #f 'line)
|
|
(let ([c (min (- b p) origc)])
|
|
(let ([p
|
|
(if (c . <= . 0)
|
|
(cond
|
|
[(and (b . <= . startp) checking-underflow? (positive? origc))
|
|
;; the word was currently force-broken; shift some part to here
|
|
(+ p origc)]
|
|
[(or (and checking-underflow?
|
|
first-underflow?
|
|
(or (b . <= . startp) (c . >= . 0)))
|
|
(and (not the-first-snip?)
|
|
(or (zero? c)
|
|
(and (zero? origc)
|
|
(c . < . 0)
|
|
(b . <= . startp)))))
|
|
;; can't fit this snip in the line
|
|
(when (snip->prev snip)
|
|
(set-snip-flags! (snip->prev snip) (add-flag (snip->flags (snip->prev snip)) NEWLINE)))
|
|
(when (and had-newline? (snip->next snip))
|
|
(set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE)))
|
|
(if (and no-change-if-start-of-snip?
|
|
(or (not had-newline?)
|
|
(snip->next snip)))
|
|
#f
|
|
(begin
|
|
(set! refresh-all? #t)
|
|
#t))]
|
|
[(and (c . < . 0) (b . > . startp))
|
|
;; overflow, but previous wordbreak was before this snip
|
|
(when had-newline?
|
|
(set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE)))
|
|
b]
|
|
[else
|
|
;; overflow: we have to break the word anyway
|
|
(if (zero? origc)
|
|
(if (and (= (snip->count snip) 1)
|
|
(snip->next snip)
|
|
(has-flag? (snip->flags (snip->next snip)) NEWLINE))
|
|
;; don't insert a break before a real newline
|
|
(done snip)
|
|
(+ p 1))
|
|
(+ p origc))])
|
|
(+ p c))])
|
|
(if (not (number? p))
|
|
p ;; the result
|
|
(begin
|
|
(make-snipset p p)
|
|
(let ([snip (find-snip p 'before)])
|
|
(when (snip->next snip)
|
|
(set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE)))
|
|
(set! refresh-all? #t)
|
|
#t))))))))
|
|
(begin
|
|
(set! the-first-snip? #f)
|
|
(set! first-underflow? #f)
|
|
(loop (snip->next snip)
|
|
(+ p (snip->count snip))
|
|
_total-width))))))
|
|
(done snip)))))
|
|
|
|
(define/private (recalc-lines dc [calc-graphics? #t])
|
|
(when calc-graphics?
|
|
(when snip-cache-invalid?
|
|
(let loop ([snip snips])
|
|
(when snip
|
|
(send snip size-cache-invalid)
|
|
(loop (snip->next snip)))))
|
|
|
|
(let ([old-max-width max-width])
|
|
(when (and flow-invalid?
|
|
(max-width . <= . 0))
|
|
(set! max-width A-VERY-BIG-NUMBER))
|
|
|
|
(when (or graphics-invalid?
|
|
flow-invalid?
|
|
snip-cache-invalid?)
|
|
;; set all lines invalid
|
|
(let loop ([line first-line])
|
|
(when line
|
|
(mline-mark-recalculate line)
|
|
(when flow-invalid?
|
|
(mline-mark-check-flow line))
|
|
(loop (mline-next line)))))
|
|
|
|
(let ([-changed?
|
|
(if (max-width . > . 0)
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
;; if any flow is updated, snip sizing methods will be called
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
|
|
(let ([w (- max-width CURSOR-WIDTH)])
|
|
(let loop ([-changed? #f])
|
|
(if (begin0
|
|
(mline-update-flow (unbox line-root-box) line-root-box this w dc
|
|
(lambda (del-line)
|
|
(when (eq? del-line first-line)
|
|
(set! first-line (mline-first (unbox line-root-box))))
|
|
(when (eq? del-line last-line)
|
|
(set! last-line (mline-last (unbox line-root-box)))))
|
|
(lambda (ins-line)
|
|
(when (not (mline-prev ins-line))
|
|
(set! first-line ins-line))
|
|
(when (not (mline-next ins-line))
|
|
(set! last-line ins-line))))
|
|
(assert (consistent-snip-lines 'post-update-flow)))
|
|
|
|
(loop #t)
|
|
|
|
(begin
|
|
(set! flow-locked? fl?)
|
|
(set! write-locked? wl?)
|
|
-changed?)))))
|
|
#f)])
|
|
|
|
(when (not (= max-width old-max-width))
|
|
(set! max-width old-max-width))
|
|
|
|
(when -changed?
|
|
(set! refresh-all? #t)
|
|
(set! first-line (mline-first (unbox line-root-box)))
|
|
(set! last-line (mline-last (unbox line-root-box)))
|
|
(set! num-valid-lines (mline-number (unbox line-root-box))))
|
|
|
|
(let ([-changed?
|
|
(or (mline-update-graphics (unbox line-root-box) this dc)
|
|
-changed?)])
|
|
|
|
(if (and (not -changed?)
|
|
(not graphic-maybe-invalid-force?))
|
|
(begin
|
|
(set! graphic-maybe-invalid? #f)
|
|
(void))
|
|
(begin
|
|
(set! graphic-maybe-invalid? #f)
|
|
(set! graphic-maybe-invalid-force? #f)
|
|
|
|
(let* ([Y (+ (mline-get-location last-line) (mline-h last-line))]
|
|
[Y (if (has-flag? (snip->flags last-snip) NEWLINE)
|
|
(begin
|
|
(set! extra-line? #t)
|
|
(set! extra-line-h (+ (mline-last-h last-line) line-spacing))
|
|
(+ Y extra-line-h))
|
|
(begin
|
|
(set! extra-line? #f)
|
|
(set! extra-line-h 0)
|
|
Y))]
|
|
[X (+ (mline-max-width (unbox line-root-box)) CURSOR-WIDTH)]
|
|
[X (if (min-width . > . 0.0)
|
|
(max X min-width)
|
|
X)]
|
|
[Y (if (min-height . > . 0.0)
|
|
(max Y min-height)
|
|
Y)]
|
|
[Y (if (max-height . > . 0.0)
|
|
(min Y max-height)
|
|
Y)])
|
|
(let ([descent (- (mline-h last-line) (mline-bottombase last-line))]
|
|
[space (mline-topbase first-line)]
|
|
[line-base (mline-bottombase first-line)])
|
|
(let ([resized?
|
|
(if (or (not (= total-height Y))
|
|
(not (= total-width X))
|
|
(not (= final-descent descent))
|
|
(not (= initial-space space))
|
|
(not (= line-base initial-line-base)))
|
|
(begin
|
|
(set! total-height Y)
|
|
(set! total-width X)
|
|
(set! final-descent descent)
|
|
(set! initial-space space)
|
|
(set! initial-line-base line-base)
|
|
#t)
|
|
#f)])
|
|
|
|
(set! graphics-invalid? #f)
|
|
(set! flow-invalid? #f)
|
|
(set! snip-cache-invalid? #f)
|
|
|
|
(set! draw-cached-in-bitmap? #f)
|
|
|
|
(when (and resized? s-admin)
|
|
(send s-admin resized #f))
|
|
|
|
(on-reflow)))))))))))
|
|
|
|
(def/public (on-reflow) (void))
|
|
|
|
(def/public (set-autowrap-bitmap [(make-or-false bitmap%) bm])
|
|
(if flow-locked?
|
|
#f
|
|
(let ([old auto-wrap-bitmap]
|
|
[old-width wrap-bitmap-width])
|
|
|
|
(set! auto-wrap-bitmap bm)
|
|
(if auto-wrap-bitmap
|
|
(set! wrap-bitmap-width (send auto-wrap-bitmap get-width))
|
|
(set! wrap-bitmap-width 0))
|
|
|
|
(when (max-width . > . 0)
|
|
(set-max-width (+ max-width old-width)))
|
|
|
|
old)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; notifies the administrator that we need to be redrawn
|
|
(define/private (redraw)
|
|
|
|
(unless (or flow-locked? (not s-admin))
|
|
(let-values ([(continue? notify?)
|
|
(if (send s-admin refresh-delayed?)
|
|
;; does the admin know the refresh box already?
|
|
(if (and (not (= delayedscroll -1))
|
|
(not delayedscrollbox?)
|
|
(or refresh-all? refresh-unset?))
|
|
;; yes...
|
|
(if (and (not refresh-all?) refresh-box-unset?)
|
|
;; nothing to do
|
|
(values #f #f)
|
|
(values #t #t))
|
|
(values #t #t))
|
|
(values #t #f))])
|
|
(when continue?
|
|
|
|
(when notify?
|
|
(let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0])
|
|
(send s-admin get-max-view x y w h)
|
|
(let ([top y]
|
|
[bottom (+ y h)]
|
|
[left x]
|
|
[right (+ x w)])
|
|
(let-values ([(left right top bottom)
|
|
(if refresh-all?
|
|
(values left right top bottom)
|
|
(values
|
|
(max refresh-l left)
|
|
(min refresh-r right)
|
|
(max refresh-t top)
|
|
(min refresh-b bottom)))])
|
|
(set! refresh-unset? #t)
|
|
(set! refresh-box-unset? #t)
|
|
(set! refresh-all? #f)
|
|
(let ([height (- bottom top)]
|
|
[width (- right left)])
|
|
(when (and (width . > . 0) (height . > . 0))
|
|
(send s-admin needs-update left top width height)))))))
|
|
|
|
(let-boxes ([dc #f]
|
|
[x 0.0]
|
|
[y 0.0])
|
|
(set-box! dc (send s-admin get-dc x y))
|
|
(if (not dc)
|
|
(begin
|
|
(set! delayedscroll -1)
|
|
(set! delayedscrollbox? #f))
|
|
|
|
(let ([origx x]
|
|
[origy y])
|
|
|
|
(recalc-lines dc)
|
|
|
|
(cond
|
|
[(not (= delayedscroll -1))
|
|
(when (scroll-to-position/refresh delayedscroll delayedscrollateol? #f
|
|
delayedscrollend delayedscrollbias)
|
|
(set! refresh-all? #t))]
|
|
[delayedscrollbox?
|
|
(set! delayedscrollbox? #f)
|
|
(when (do-scroll-to delayedscrollsnip delayedscroll-x delayedscroll-y
|
|
delayedscroll-w delayedscroll-h #f delayedscrollbias)
|
|
(set! refresh-all? #t))])
|
|
(let-boxes ([x 0.0]
|
|
[y 0.0])
|
|
(send s-admin get-dc x y)
|
|
(when (or (not (= origx x)) (not (= origy y)))
|
|
(set! refresh-all? #t)))
|
|
|
|
(let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0])
|
|
(send s-admin get-max-view x y w h)
|
|
(let ([top y]
|
|
[bottom (+ y h)]
|
|
[left x]
|
|
[right (+ x w)])
|
|
|
|
;; figure out the minimal refresh area; the refresh area may be
|
|
;; determined by character position ranges, box coordinates, or
|
|
;; both; if neither is specified, we have to assume that everything
|
|
;; needs to be refreshed
|
|
(let-values ([(left top right bottom needs-update?)
|
|
(if (and (not refresh-all?)
|
|
(or (not refresh-unset?) (not refresh-box-unset?)))
|
|
(if (not refresh-unset?)
|
|
(let ([top (if (refresh-start . > . -1)
|
|
(let-boxes ([fy 0.0])
|
|
(position-location refresh-start #f fy #t #t #t)
|
|
(max top fy))
|
|
top)]
|
|
[bottom (if (refresh-end . > . -1)
|
|
(let-boxes ([fy 0.0])
|
|
(position-location refresh-end #f fy #f #f #t)
|
|
(min bottom fy))
|
|
bottom)])
|
|
(values left (if (not refresh-box-unset?)
|
|
(min refresh-t top)
|
|
top)
|
|
right (if (not refresh-box-unset?)
|
|
(max bottom refresh-b)
|
|
bottom)
|
|
#t))
|
|
(values (max refresh-l left)
|
|
(max top refresh-t)
|
|
(min right refresh-r)
|
|
(min bottom refresh-b)
|
|
#t))
|
|
(values left top right bottom refresh-all?))])
|
|
|
|
(set! refresh-unset? #t)
|
|
(set! refresh-box-unset? #t)
|
|
(set! refresh-all? #f)
|
|
|
|
(let ([height (- bottom top)]
|
|
[width (- right left)])
|
|
|
|
(when changed?
|
|
(set! changed? #f)
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
(on-change)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?)))
|
|
|
|
(when (and needs-update?
|
|
(width . > . 0)
|
|
(height . > . 0))
|
|
(send s-admin needs-update left top width height)))))))))))))
|
|
|
|
(define/private (too-busy-to-refresh?)
|
|
(or graphic-maybe-invalid?
|
|
flow-locked?
|
|
(positive? delay-refresh)))
|
|
|
|
;; called by the administrator to trigger a redraw
|
|
(def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height]
|
|
[(symbol-in no-caret show-inactive-caret show-caret) show-caret]
|
|
[(make-or-false color%) bg-color])
|
|
(cond
|
|
[(or (width . <= . 0) (height . <= . 0)) (void)]
|
|
[(too-busy-to-refresh?)
|
|
;; this refresh command was not requested by us and we're busy
|
|
;; (probably in the middle of a begin-/end-edit-sequnce);
|
|
;; add the given region to our own invalid-region tracking, and
|
|
;; we'll get back to it when we're done with whatever
|
|
(refresh-box left top width height)]
|
|
[(not s-admin)
|
|
(void)]
|
|
[else
|
|
(let-boxes ([x 0.0]
|
|
[y 0.0]
|
|
[dc #f])
|
|
(set-box! dc (send s-admin get-dc x y))
|
|
(when dc
|
|
(begin-sequence-lock)
|
|
|
|
(let ([show-caret
|
|
(if (and caret-blinked?
|
|
(not (eq? show-caret 'no-caret))
|
|
(not s-caret-snip))
|
|
;; maintain caret-blinked invariant
|
|
'no-caret
|
|
show-caret)])
|
|
|
|
(when (send s-offscreen ready-offscreen width height)
|
|
(set! draw-cached-in-bitmap? #f))
|
|
|
|
;; make sure all location information is integral,
|
|
;; so we can shift the coordinate system and generally
|
|
;; update on pixel boundaries
|
|
(let ([x (->long (floor x))]
|
|
[y (->long (floor y))]
|
|
[bottom (->long (ceiling (+ top height)))]
|
|
[right (->long (ceiling (+ left width)))]
|
|
[top (->long (floor top))]
|
|
[left (->long (floor left))])
|
|
(let ([width (- right left)]
|
|
[height (- bottom top)]
|
|
[ps? (or (dc . is-a? . post-script-dc%)
|
|
(dc . is-a? . printer-dc%))]
|
|
[show-xsel?
|
|
(and ALLOW-X-STYLE-SELECTION?
|
|
(or (not (eq? 'show-caret show-caret)) s-caret-snip)
|
|
(eq? this editor-x-selection-owner)
|
|
(not flash?)
|
|
(not (= endpos startpos)))])
|
|
|
|
(if (and bg-color
|
|
(not (send s-offscreen is-in-use?))
|
|
(send s-offscreen get-bitmap)
|
|
(send (send s-offscreen get-bitmap) ok?)
|
|
(send (send s-offscreen get-dc) ok?)
|
|
(not ps?))
|
|
;; draw to offscreen
|
|
(let ([red (send bg-color red)]
|
|
[green (send bg-color green)]
|
|
[blue (send bg-color blue)])
|
|
(send s-offscreen set-in-use #t)
|
|
|
|
(when (or
|
|
(not draw-cached-in-bitmap?)
|
|
(not (eq? offscreen-key (send s-offscreen get-last-used)))
|
|
(not (= last-draw-t top))
|
|
(not (= last-draw-b bottom))
|
|
(not (= last-draw-l left))
|
|
(not (= last-draw-r right))
|
|
(not (eq? show-caret last-draw-caret))
|
|
(not (eq? show-xsel? last-draw-x-sel?))
|
|
(not (= last-draw-red red))
|
|
(not (= last-draw-green green))
|
|
(not (= last-draw-blue blue)))
|
|
|
|
(do-redraw (send s-offscreen get-dc) top bottom left right
|
|
(- top) (- left) show-caret show-xsel? bg-color)
|
|
|
|
(set! last-draw-l left)
|
|
(set! last-draw-t top)
|
|
(set! last-draw-r right)
|
|
(set! last-draw-b bottom)
|
|
(set! last-draw-caret show-caret)
|
|
(set! last-draw-x-sel? show-xsel?)
|
|
(set! last-draw-red red)
|
|
(set! last-draw-green green)
|
|
(set! last-draw-blue blue)
|
|
(set! draw-cached-in-bitmap? #t))
|
|
|
|
(send dc draw-bitmap-section
|
|
(send (send s-offscreen get-dc) get-bitmap)
|
|
(- left x) (- top y)
|
|
0 0 width height 'solid)
|
|
|
|
(send s-offscreen set-last-used offscreen-key)
|
|
(send s-offscreen set-in-use #f))
|
|
|
|
;; draw to given DC:
|
|
(let ([pen (send dc get-pen)]
|
|
[brush (send dc get-brush)]
|
|
[font (send dc get-font)]
|
|
[fg (make-object color% (send dc get-text-foreground))]
|
|
[bg (make-object color% (send dc get-text-background))]
|
|
[bgmode (send dc get-text-mode)]
|
|
[rgn (send dc get-clipping-region)])
|
|
|
|
(send dc set-clipping-rect (- left x) (- top y) width height)
|
|
|
|
(do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color)
|
|
|
|
(send dc set-clipping-region rgn)
|
|
|
|
(send dc set-brush brush)
|
|
(send dc set-pen pen)
|
|
(send dc set-font font)
|
|
(send dc set-text-foreground fg)
|
|
(send dc set-text-background bg)
|
|
(send dc set-text-mode bgmode))))))
|
|
|
|
(end-sequence-lock)))]))
|
|
|
|
;; performs the actual drawing operations
|
|
(define/private (do-redraw dc starty endy leftx rightx dy dx show-caret show-xsel? bg-color)
|
|
(let ([wl? write-locked?])
|
|
|
|
(set! flow-locked? #t)
|
|
(set! write-locked? #t)
|
|
|
|
(let-values ([(-startpos -endpos pos-at-eol?)
|
|
(if flash?
|
|
(values flashstartpos flashendpos flashposateol?)
|
|
(values startpos endpos posateol?))])
|
|
|
|
(send dc set-text-mode 'solid)
|
|
|
|
(let ([line (mline-find-location (unbox line-root-box) starty)])
|
|
|
|
(when bg-color
|
|
(let ([lsave-pen (send dc get-pen)]
|
|
[lsave-brush (send dc get-brush)])
|
|
(let ([wb (if (and (= 255 (send bg-color red))
|
|
(= 255 (send bg-color green))
|
|
(= 255 (send bg-color blue)))
|
|
clear-brush
|
|
(send the-brush-list find-or-create-brush bg-color 'solid))])
|
|
(send dc set-brush wb)
|
|
(send dc set-pen outline-pen)
|
|
|
|
(send dc draw-rectangle
|
|
(+ leftx dx) (+ starty dy)
|
|
(- rightx leftx) (- endy starty))
|
|
|
|
(send dc set-brush lsave-brush)
|
|
(send dc set-pen lsave-pen))))
|
|
|
|
(let* ([call-on-paint
|
|
(lambda (pre?)
|
|
(on-paint pre? dc leftx starty rightx endy dx dy
|
|
(if (not s-caret-snip)
|
|
show-caret
|
|
'no-caret)))]
|
|
[paint-done
|
|
(lambda ()
|
|
(call-on-paint #f)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? #f))])
|
|
|
|
(call-on-paint #t)
|
|
|
|
(when line
|
|
(let ([tleftx (+ leftx dx)]
|
|
[tstarty (+ starty dy)]
|
|
[trightx (+ rightx dx)]
|
|
[tendy (+ endy dy)])
|
|
(let lloop ([line line]
|
|
[old-style #f]
|
|
[ycounter (mline-get-location line)]
|
|
[pcounter (mline-get-position line)]
|
|
[prevwasfirst 0.0])
|
|
(cond
|
|
[(not line)
|
|
(send (send s-style-list basic-style) switch-to dc old-style)
|
|
(when (and (eq? 'show-caret show-caret) (not s-caret-snip)
|
|
extra-line?
|
|
(not pos-at-eol?)
|
|
(= len -startpos)
|
|
(= -endpos -startpos)
|
|
hilite-on?)
|
|
(let ([y ycounter]
|
|
[save-pen (send dc get-pen)])
|
|
(send dc set-pen caret-pen)
|
|
(send dc draw-line dx (+ y dy) dx (sub1 (+ y extra-line-h dy)))
|
|
(send dc set-pen save-pen)))
|
|
(paint-done)]
|
|
[(ycounter . >= . endy)
|
|
(paint-done)]
|
|
[line
|
|
(let ([first (mline-snip line)]
|
|
[last (snip->next (mline-last-snip line))]
|
|
[bottombase (+ ycounter (mline-bottombase line))]
|
|
[topbase (+ ycounter (mline-topbase line))])
|
|
(let-values ([(hilite-some? hsxs hsxe hsys hsye old-style)
|
|
(let sloop ([snip first]
|
|
[p pcounter]
|
|
[x (mline-get-left-location line max-width)]
|
|
[hilite-some? #f]
|
|
[hsxs 0.0]
|
|
[hsxe 0.0]
|
|
[hsys 0.0]
|
|
[hsye 0.0]
|
|
[old-style old-style])
|
|
(if (eq? snip last)
|
|
(values hilite-some? hsxs hsxe hsys hsye old-style)
|
|
(begin
|
|
(send (snip->style snip) switch-to dc old-style)
|
|
(let ([old-style (snip->style snip)])
|
|
(let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0])
|
|
(send snip get-extent dc x ycounter w h descent space #f #f)
|
|
(let* ([align (send (snip->style snip) get-alignment)]
|
|
[down
|
|
(cond
|
|
[(eq? 'bottom align)
|
|
(+ (- bottombase h) descent)]
|
|
[(eq? 'top align)
|
|
(- topbase space)]
|
|
[else
|
|
(- (/ (+ topbase bottombase) 2)
|
|
(/ (- h descent space) 2)
|
|
space)])])
|
|
|
|
(when (and (x . <= . rightx)
|
|
((+ x w) . >= . leftx))
|
|
(send snip draw dc (+ x dx) (+ down dy)
|
|
tleftx tstarty trightx tendy
|
|
dx dy
|
|
(if (eq? snip s-caret-snip)
|
|
show-caret
|
|
'no-caret)))
|
|
|
|
;; the rules for hiliting are surprisingly complicated:
|
|
(let ([hilite?
|
|
(and
|
|
hilite-on?
|
|
(or show-xsel?
|
|
(and (not s-caret-snip)
|
|
(or (eq? 'show-caret show-caret)
|
|
(and (show-caret . showcaret>= . s-inactive-caret-threshold)
|
|
(not (= -endpos -startpos))))))
|
|
(if pos-at-eol?
|
|
(= -startpos (+ p (snip->count snip)))
|
|
(or (and (-startpos . < . (+ p (snip->count snip)))
|
|
(-endpos . >= . p)
|
|
(or (= -endpos -startpos) (-endpos . > . p)))
|
|
(and (= (+ p (snip->count snip)) len)
|
|
(= len -startpos))))
|
|
(or (not (has-flag? (snip->flags snip) NEWLINE))
|
|
;; end of line:
|
|
(or (not (= -startpos (+ p (snip->count snip))))
|
|
(and (= -endpos -startpos) pos-at-eol?)
|
|
(and (not (= -endpos -startpos))
|
|
(-startpos . < . (+ p (snip->count snip))))))
|
|
(or (not (eq? snip first))
|
|
;; beginning of line:
|
|
(or (not (= p -endpos))
|
|
(and (= -endpos -startpos) (not pos-at-eol?))
|
|
(and (not (= -endpos -startpos))
|
|
(-endpos . > . p)))))])
|
|
|
|
(if hilite?
|
|
(let*-values ([(bottom) (+ down h)]
|
|
[(hxs) (if (-startpos . <= . p)
|
|
(if (-startpos . < . p)
|
|
0
|
|
x)
|
|
(+ x (send snip partial-offset dc x ycounter
|
|
(- -startpos p))))]
|
|
[(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip)))
|
|
(if (has-flag? (snip->flags snip) NEWLINE)
|
|
(if (= -startpos -endpos)
|
|
(values hxs bottom)
|
|
(values rightx
|
|
(+ ycounter (mline-h line))))
|
|
(values (+ x w) bottom))
|
|
(values (+ x (send snip partial-offset dc x ycounter
|
|
(- -endpos p)))
|
|
bottom))])
|
|
|
|
(let-values ([(hsxs hsxe hsys hsye)
|
|
(if (not hilite-some?)
|
|
(values hxs hxe down bottom)
|
|
(values hsxs hxe (min down hsys) (max hsye bottom)))])
|
|
(sloop (snip->next snip)
|
|
(+ p (snip->count snip))
|
|
(+ x w)
|
|
#t hsxs hsxe hsys hsye
|
|
old-style)))
|
|
(sloop (snip->next snip)
|
|
(+ p (snip->count snip))
|
|
(+ x w)
|
|
hilite-some? hsxs hsxe hsys hsye
|
|
old-style)))))))))])
|
|
(when (and (positive? wrap-bitmap-width)
|
|
(not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE))
|
|
last
|
|
(rightx . >= . max-width)
|
|
(send auto-wrap-bitmap ok?))
|
|
(let ([h (min (->long (send auto-wrap-bitmap get-height))
|
|
(mline-bottombase line))]
|
|
[osfg (send old-style get-foreground)])
|
|
(send dc draw-bitmap-section
|
|
auto-wrap-bitmap
|
|
(sub1 (+ max-width dx)) (+ (- bottombase h) dy)
|
|
0 0 wrap-bitmap-width h
|
|
'solid osfg)))
|
|
|
|
(let ([prevwasfirst
|
|
(if hilite-some?
|
|
(if (not (= hsxs hsxe))
|
|
(if (and (hsxs . <= . rightx) (hsxe . >= . leftx))
|
|
(let ([save-pen (send dc get-pen)]
|
|
[hxsx (max hsxs leftx)]
|
|
[hsxe (min hsxe rightx)])
|
|
(begin0
|
|
(if (and (not show-xsel?)
|
|
(not (showcaret>= show-caret 'show-caret)))
|
|
(if show-outline-for-inactive?
|
|
(let ([first-hilite? (-startpos . >= . pcounter)]
|
|
[last-hilite? (-endpos . <= . (+ pcounter (mline-len line)))])
|
|
(send dc set-pen outline-inactive-pen)
|
|
(let ([prevwasfirst
|
|
(cond
|
|
[first-hilite?
|
|
(send dc draw-line (+ hsxs dx) (+ hsys dy) (+ hsxe (sub1 dx)) (+ hsys dy))
|
|
hsxs]
|
|
[(positive? prevwasfirst)
|
|
(send dc draw-line dx (+ hsys dy) (+ prevwasfirst dx) (+ hsys dy))
|
|
0.0]
|
|
[else 0.0])])
|
|
(send dc draw-line (+ hsxs dx) (+ hsys dy) (+ hsxs dx) (+ hsye (sub1 dy)))
|
|
(send dc draw-line (+ hsxe (sub1 dx)) (+ hsys dy)
|
|
(+ hsxe (sub1 dx)) (+ hsye (sub1 dy)))
|
|
(when last-hilite?
|
|
(send dc draw-line (+ hsxs dx) (+ hsye dy) (+ hsxe (sub1 dx)) (+ hsye dy)))
|
|
(when (not first-hilite?)
|
|
(send dc draw-line (+ hsxe dx) (+ hsys dy) (+ rightx dx) (+ hsys dy)))
|
|
prevwasfirst))
|
|
prevwasfirst)
|
|
(let ([save-brush (send dc get-brush)])
|
|
(send dc set-pen outline-pen)
|
|
(send dc set-brush outline-brush)
|
|
|
|
(send dc draw-rectangle (+ hsxs dx) (+ hsys dy)
|
|
(max 0.0 (- hsxe hsxs)) (max 0.0 (- hsye hsys)))
|
|
(when ALLOW-X-STYLE-SELECTION?
|
|
(when show-xsel?
|
|
(send dc set-brush outline-nonowner-brush)
|
|
(send dc draw-rectangle (+ hsxs dx) (+ hsys dy)
|
|
(max 0.0 (- hsxe hsxs)) (max 0.0 (- hsye hsys)))))
|
|
(send dc set-brush save-brush)
|
|
prevwasfirst))
|
|
(send dc set-pen save-pen)))
|
|
prevwasfirst)
|
|
(begin
|
|
(when (eq? 'show-caret show-caret)
|
|
(when (and (hsxs . <= . rightx) (hsxs . >= . leftx))
|
|
(let ([save-pen (send dc get-pen)])
|
|
(send dc set-pen caret-pen)
|
|
(send dc draw-line (+ hsxs dx) (+ hsys dy)
|
|
(+ hsxs dx)
|
|
(+ hsye (sub1 dy)))
|
|
(send dc set-pen save-pen))))
|
|
prevwasfirst))
|
|
prevwasfirst)])
|
|
(lloop (mline-next line)
|
|
old-style
|
|
(+ ycounter (mline-h line))
|
|
(+ pcounter (mline-len line))
|
|
prevwasfirst))))])))))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; used internally to delay refreshes:
|
|
(define/private (need-refresh start [end -1])
|
|
(if refresh-unset?
|
|
(begin
|
|
(set! refresh-start start)
|
|
(set! refresh-end end)
|
|
(set! refresh-unset? #f))
|
|
(begin
|
|
(set! refresh-start (min start refresh-start))
|
|
(cond
|
|
[(= end -1)
|
|
(set! refresh-end -1)]
|
|
[(= refresh-end -1)
|
|
(void)]
|
|
[else (set! refresh-end (max end refresh-end))])))
|
|
|
|
(set! draw-cached-in-bitmap? #f)
|
|
|
|
(continue-refresh))
|
|
|
|
(define/private (refresh-by-line-demand)
|
|
(set! graphic-maybe-invalid? #t)
|
|
(continue-refresh))
|
|
|
|
(define/private (continue-refresh)
|
|
(if (and (zero? delay-refresh)
|
|
(not (super is-printing?))
|
|
(or (not s-admin) (not (send s-admin refresh-delayed?))))
|
|
(redraw)
|
|
(begin
|
|
(when (and (zero? delay-refresh)
|
|
(or (= delayedscroll -1)
|
|
delayedscrollbox?))
|
|
(if (and (not (super is-printing?)) s-admin)
|
|
;; although the administrator says to delay,
|
|
;; we can't just drop scroll requests
|
|
(redraw)
|
|
(begin
|
|
(set! delayedscroll -1)
|
|
(set! delayedscrollbox? #f))))
|
|
(when (and s-admin (zero? (send s-admin get-s-standard)))
|
|
(send s-admin resized #f)))))
|
|
|
|
(define/private (need-caret-refresh)
|
|
(need-refresh startpos endpos))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/override (own-x-selection on? update? force?)
|
|
(and (do-own-x-selection on? force?)
|
|
(begin
|
|
(when update?
|
|
(need-caret-refresh))
|
|
#t)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/public (set-paragraph-margins [exact-nonnegative-integer? i]
|
|
[nonnegative-real? first-left]
|
|
[nonnegative-real? left]
|
|
[nonnegative-real? right])
|
|
(let ([l (mline-find-paragraph (unbox line-root-box) i)])
|
|
(when l
|
|
(let ([p (mline-clone-paragraph (mline-paragraph l))])
|
|
(set-mline-paragraph! l p)
|
|
|
|
(set-paragraph-left-margin-first! p first-left)
|
|
(set-paragraph-left-margin! p left)
|
|
(set-paragraph-right-margin! p right)
|
|
|
|
(if (max-width . > . 0)
|
|
(begin
|
|
(mline-mark-check-flow l)
|
|
(let loop ([l (mline-next l)])
|
|
(when (and l
|
|
(zero? (mline-starts-paragraph l)))
|
|
(mline-mark-check-flow l)
|
|
(loop (mline-next l)))))
|
|
(need-refresh (paragraph-start-position i) (paragraph-end-position i)))
|
|
|
|
(refresh-by-line-demand)))))
|
|
|
|
(def/public (set-paragraph-alignment [exact-nonnegative-integer? i] [(symbol-in left center right) align])
|
|
(let ([l (mline-find-paragraph (unbox line-root-box) i)])
|
|
(when l
|
|
(let ([p (mline-clone-paragraph (mline-paragraph l))])
|
|
(set-mline-paragraph! l p)
|
|
|
|
(set-paragraph-alignment! p align)
|
|
|
|
(need-refresh (paragraph-start-position i) (paragraph-end-position i))
|
|
|
|
(refresh-by-line-demand)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(def/override (is-printing?) (super is-printing?))
|
|
|
|
(define/override (do-begin-print dc fit?)
|
|
(if flow-locked?
|
|
#f
|
|
(begin
|
|
(check-recalc)
|
|
(size-cache-invalid)
|
|
|
|
(let ([save-info (if fit?
|
|
(cons (get-max-width)
|
|
(set-autowrap-bitmap #f))
|
|
#f)])
|
|
(when fit?
|
|
(let-values ([(w h) (send dc get-size)])
|
|
(let-boxes ([hm 0]
|
|
[vm 0])
|
|
(send (current-ps-setup) get-editor-margin hm vm)
|
|
(set-max-width (- w (* 2 hm))))))
|
|
|
|
(recalc-lines dc #t)
|
|
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
(on-change)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?))
|
|
|
|
save-info))))
|
|
|
|
(define/override (do-end-print dc data)
|
|
(unless flow-locked?
|
|
(size-cache-invalid)
|
|
|
|
(when data
|
|
(set-max-width (car data))
|
|
(set-autowrap-bitmap (cdr data)))
|
|
|
|
(let ([wl? write-locked?]
|
|
[fl? flow-locked?])
|
|
(set! write-locked? #t)
|
|
(set! flow-locked? #t)
|
|
(on-change)
|
|
(set! write-locked? wl?)
|
|
(set! flow-locked? fl?))))
|
|
|
|
(define/private (new-page-line? line)
|
|
(let ([len (mline-len line)])
|
|
(and (<= 1 len 2)
|
|
(let* ([pos (mline-get-position line)]
|
|
[s (get-text pos (+ pos len))])
|
|
(or (equal? s "\f")
|
|
(equal? s "\f\n"))))))
|
|
|
|
(define/private (has/print-page dc page print?)
|
|
(if flow-locked?
|
|
#f
|
|
(begin
|
|
(recalc-lines dc #t)
|
|
(let-values ([(W H) (send dc get-size)])
|
|
(let-boxes ([W W]
|
|
[H H]
|
|
[hm 0]
|
|
[vm 0])
|
|
(begin
|
|
(when (or (zero? (unbox W)) (zero? (unbox H)))
|
|
(get-default-print-size W H))
|
|
(send (current-ps-setup) get-editor-margin hm vm))
|
|
(let ([H (- H (* 2 vm))]
|
|
[W (- W (* 2 hm))])
|
|
|
|
;; H is the total page height;
|
|
;; line is the line that we haven't finished printing;
|
|
;; y is the starting location to print for this page;
|
|
;; h is the height that we're hoping to fit into the page
|
|
;; i is the line number
|
|
(let ploop ([this-page 1]
|
|
[line first-line]
|
|
[y 0.0]
|
|
[next-h 0.0]
|
|
[i 0])
|
|
(and
|
|
line
|
|
(let ([h next-h]
|
|
[next-h 0.0])
|
|
(let loop ([h h]
|
|
[i i]
|
|
[line line]
|
|
[can-continue? #t]
|
|
[unline 0.0])
|
|
(cond
|
|
[(or (zero? h)
|
|
(and (i . < . num-valid-lines)
|
|
((mline-h line) . < . (- H h))
|
|
can-continue?))
|
|
(let ([lh (mline-h line)]
|
|
[new-page? (new-page-line? line)])
|
|
(loop (+ h lh)
|
|
(add1 i)
|
|
(mline-next line)
|
|
(not new-page?)
|
|
(if new-page? lh unline)))]
|
|
[else
|
|
(let-values ([(h i line)
|
|
(cond
|
|
[(and (h . < . H)
|
|
(i . < . num-valid-lines)
|
|
((mline-h line) . > . H))
|
|
;; we'll have to break it up anyway; start now?
|
|
(let* ([pos (find-scroll-line (+ y H))]
|
|
[py (scroll-line-location pos)])
|
|
(if (py . > . (+ y h))
|
|
;; yes, at least one line will fit
|
|
(values (+ h (mline-h line))
|
|
(add1 i)
|
|
(mline-next line))
|
|
(values h i line)))]
|
|
[else
|
|
(values h i line)])])
|
|
(let-values ([(next-h h)
|
|
(if (h . > . H)
|
|
;; only happens if we have something that's too big to fit on a page;
|
|
;; look for internal scroll positions
|
|
(let* ([pos (find-scroll-line (+ y H))]
|
|
[py (scroll-line-location pos)])
|
|
(if (py . > . y)
|
|
(let ([new-h (- py y)])
|
|
(values (- h new-h)
|
|
new-h))
|
|
(values next-h h)))
|
|
(values next-h h))])
|
|
(or (if print?
|
|
(begin
|
|
(when (or (negative? page) (= this-page page))
|
|
(begin
|
|
(when (negative? page)
|
|
(send dc start-page))
|
|
(do-redraw dc
|
|
(+ y (if (zero? i) 0 1))
|
|
(+ y (- h 1 unline))
|
|
0 W (+ (- y) vm) hm
|
|
'no-caret #f #f)
|
|
(when (negative? page)
|
|
(send dc end-page))))
|
|
#f)
|
|
(= this-page page))
|
|
(ploop (add1 this-page)
|
|
line
|
|
(+ y h)
|
|
next-h
|
|
i))))])))))))))))
|
|
|
|
(define/override (do-has-print-page? dc page)
|
|
(has/print-page dc page #f))
|
|
|
|
(def/override (print-to-dc [dc<%> dc] [exact-integer? [page -1]])
|
|
(has/print-page dc page #t)
|
|
(void)))
|
|
|
|
(set-text%! text%)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/top (add-text-keymap-functions [keymap% tab])
|
|
(let ([add (lambda (n f)
|
|
(send tab add-function n
|
|
(lambda (e evt)
|
|
(if (e . is-a? . text%)
|
|
(begin (f e evt) #t)
|
|
#f))))])
|
|
(add "forward-character" (lambda (t evt) (send t move-position 'right)))
|
|
(add "backward-character" (lambda (t evt) (send t move-position 'left)))
|
|
(add "previous-line" (lambda (t evt) (send t move-position 'up)))
|
|
(add "next-line" (lambda (t evt) (send t move-position 'down)))
|
|
(add "previous-page" (lambda (t evt) (send t move-position 'up #f 'page)))
|
|
(add "next-page" (lambda (t evt) (send t move-position 'down #f 'page)))
|
|
(add "forward-word" (lambda (t evt) (send t move-position 'right #f 'word)))
|
|
(add "backward-word" (lambda (t evt) (send t move-position 'left #f 'word)))
|
|
|
|
(add "forward-select" (lambda (t evt) (send t move-position 'right #t)))
|
|
(add "backward-select" (lambda (t evt) (send t move-position 'left #t)))
|
|
(add "select-down" (lambda (t evt) (send t move-position 'down #t)))
|
|
(add "select-up" (lambda (t evt) (send t move-position 'up #t)))
|
|
(add "select-page-up" (lambda (t evt) (send t move-position 'up #t 'page)))
|
|
(add "select-page-down" (lambda (t evt) (send t move-position 'down #t 'page)))
|
|
(add "forward-select-word" (lambda (t evt) (send t move-position 'right #t 'word)))
|
|
(add "backward-select-word" (lambda (t evt) (send t move-position 'left #t 'word)))
|
|
|
|
(add "beginning-of-file" (lambda (t evt) (send t move-position 'home)))
|
|
(add "end-of-file" (lambda (t evt) (send t move-position 'end)))
|
|
(add "beginning-of-line" (lambda (t evt) (send t move-position 'left #f 'line)))
|
|
(add "end-of-line" (lambda (t evt) (send t move-position 'right #f 'line)))
|
|
|
|
(add "select-to-beginning-of-file" (lambda (t evt) (send t move-position 'home #t)))
|
|
(add "select-to-end-of-file" (lambda (t evt) (send t move-position 'end #t)))
|
|
(add "select-to-beginning-of-line" (lambda (t evt) (send t move-position 'left #t 'line)))
|
|
(add "select-to-end-of-line" (lambda (t evt) (send t move-position 'right #t 'line)))
|
|
|
|
(add "delete-previous-character" (lambda (t evt) (send t delete)))
|
|
(add "delete-next-character" (lambda (t evt)
|
|
(let-boxes ([s 0]
|
|
[e 0])
|
|
(send t get-position s e)
|
|
(if (not (= s e))
|
|
(send t delete)
|
|
(send t delete s (+ s 1))))))
|
|
|
|
(add "clear-buffer" (lambda (t evt) (send t erase)))
|
|
(add "delete-next-word" (lambda (t evt)
|
|
(send t begin-edit-sequence)
|
|
(send t move-position 'right #t 'word)
|
|
(send t delete)
|
|
(send t end-edit-sequence)))
|
|
(add "delete-previous-word" (lambda (t evt)
|
|
(send t begin-edit-sequence)
|
|
(send t move-position 'left #t 'word)
|
|
(send t delete)
|
|
(send t end-edit-sequence)))
|
|
(add "delete-line" (lambda (t evt)
|
|
(send t begin-edit-sequence)
|
|
(send t move-position 'left #f 'line)
|
|
(send t move-position 'right #t 'line)
|
|
(send t delete)
|
|
(send t end-edit-sequence)))
|
|
|
|
(add "paste-next" (lambda (t evt) (send t paste-next)))
|
|
|
|
(add-editor-keymap-functions tab)))
|