diff --git a/collects/mred/private/seqcontract.rkt b/collects/mred/private/seqcontract.rkt index 0d22e5d5df..86b260f40c 100644 --- a/collects/mred/private/seqcontract.rkt +++ b/collects/mred/private/seqcontract.rkt @@ -243,7 +243,7 @@ Matthew (and (not (locked-for-write?)) (not (locked-for-flow?)) (not (locked-for-read?))) - (set-position [(x) (x y) (x y z) (x y z p) (x y z p q)] unlocked) + (set-position [(x) (x y) (x y z) (x y z p) (x y z p q) (x y z p q r)] unlocked) (set-autowrap-bitmap [(bitmap)] unlocked) (print-to-dc [(dc) (dc page)] unlocked) (move-position [(code?) (code? extend) (code? extend kind)] unlocked) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 6a75b34e35..4071cb3184 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -792,7 +792,7 @@ [any? [ateol? #f]] [any? [scroll? #t]] [(symbol-in default x local) [seltype 'default]]) - (do-set-position #f 'none start end ateol? scroll? seltype)) + (do-set-position #f 'none start end ateol? scroll? seltype #f)) (def/public (set-position-bias-scroll [symbol? bias] [exact-nonnegative-integer? start] @@ -800,13 +800,13 @@ [any? [ateol? #f]] [any? [scroll? #t]] [(symbol-in default x local) [seltype 'default]]) - (do-set-position #f bias start end ateol? scroll? seltype)) + (do-set-position #f bias start end ateol? scroll? seltype #f)) - (define/private (do-set-position setflash? bias start end ateol? scroll? seltype) + (define/private (do-set-position setflash? bias start end ateol? scroll? seltype dont-end-cursor?) (unless flow-locked? (when (and (not setflash?) (or (not flash?) (not flashautoreset?) (not flashdirectoff?))) - (end-streaks '(delayed))) + (end-streaks (if dont-end-cursor? '(cursor delayed) '(delayed)))) (unless (or (start . < . 0) (and (number? end) @@ -981,6 +981,28 @@ ;; ---------------------------------------- + (def/public (extend-position [exact-nonnegative-integer? dest]) + (cond + [extend-streak? + (values extendstartpos extendendpos)] + [anchor-streak? + (set! extend-streak? #t) + (values extendstartpos extendendpos)] + [else + (set! extend-streak? #t) + (set! extendstartpos startpos) + (set! extendendpos endpos)]) + + (define-values (start end bias) + (cond + [(dest . < . extendstartpos) + (values dest extendendpos 'start)] + [(dest . > . extendendpos) + (values extendstartpos dest 'end)] + [else + (values extendstartpos extendendpos 'none)])) + (do-set-position #f bias start end #f #t 'default #t)) + (def/public (move-position [(make-alts symbol? char?) code] [any? [extend-selection? #f]] [(symbol-in simple word page line) [kind 'simple]]) @@ -1236,6 +1258,9 @@ (set! extendendpos endpos) (set! extendstartpos startpos)))) + (def/public (get-extend-start-position) (if (or extend-streak? anchor-streak?) extendstartpos startpos)) + (def/public (get-extend-end-position) (if (or extend-streak? anchor-streak?) extendendpos endpos)) + (def/public (get-anchor) anchor-streak?) @@ -2449,7 +2474,7 @@ [any? [ateol? #f]] [any? [scroll? #t]] [exact-nonnegative-integer? [timeout 500]]) - (do-set-position #t 'none start end ateol? scroll? 'default) + (do-set-position #t 'none start end ateol? scroll? 'default #f) (when (timeout . > . 0) (set! flashautoreset? #t) (when flash-timer @@ -2462,7 +2487,7 @@ (when flash? (set! flashautoreset? #t) (set! flashdirectoff? #t) - (do-set-position #f 'none startpos endpos posateol? flashscroll? 'default))) + (do-set-position #f 'none startpos endpos posateol? flashscroll? 'default #f))) ;; ---------------------------------------- diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 4d523b37e6..13c7b4f234 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -498,6 +498,19 @@ See also @method[text% delete]. } +@defmethod[(extend-position [pos exact-nonnegative-integer?]) void?]{ + Updates the selection (see @method[text% set-position]) based on + the result of @method[text% get-extend-end-position], + @method[text% get-extend-start-position], and @racket[pos]. + + If @racket[pos] is before the extend start and extend end positions, + then the selection goes from @racket[pos] to the extend end position. + If it is after, then the selection goes from the extend start position + to @racket[pos]. + + Use this method to implement shift-modified movement keys in order to + properly extend the selection. +} @defmethod[(find-line [y real?] [on-it? (or/c (box/c any/c) #f) #f]) @@ -749,7 +762,6 @@ Returns @scheme[#t] if the selection is currently auto-extending. See } - @defmethod[(get-between-threshold) (and/c real? (not/c negative?))]{ @@ -784,6 +796,17 @@ Returns the ending @techlink{position} of the current selection. See } +@defmethod[(get-extend-start-position) exact-nonnegative-integer?]{ + Returns the beginning of the ``extend'' region if the selection + is currently being extended via, e.g., shift and a cursor movement key; + otherwise returns the same value as @method[text% get-end-position]. +} + +@defmethod[(get-extend-end-position) exact-nonnegative-integer?]{ + Returns the beginning of the ``extend'' region if the selection + is currently being extended via, e.g., shift and a cursor movement key; + otherwise returns the same value as @method[text% get-start-position]. +} @defmethod[(get-file-format) (or/c 'standard 'text 'text-force-cr)]{ @@ -1294,7 +1317,8 @@ The possible values for @scheme[code] are: If @scheme[extend?] is not @scheme[#f], the selection range is extended instead of moved. If anchoring is on (see @method[text% get-anchor] and @method[text% set-anchor]), then @scheme[extend?] is - effectively forced to @scheme[#t]. + effectively forced to @scheme[#t]. See also @method[text% get-extend-start-position] + and @method[text% get-extend-end-position]. The possible values for @scheme[kind] are: @@ -1779,7 +1803,8 @@ Turns anchoring on or off. This method can be overridden to affect or If @scheme[on?] is not @scheme[#f], then the selection will be automatically extended when cursor keys are used (or, more generally, - when @method[text% move-position] is used to move the selection), + when @method[text% move-position] is used to move the selection or the + @racket[_keep-anchor?] argument to @method[text% set-position] is a true value), otherwise anchoring is turned off. Anchoring is automatically turned off if the user does anything besides cursor movements. @@ -1982,7 +2007,6 @@ See also @scheme[editor-set-x-selection-mode]. } - @defmethod[(set-position-bias-scroll [bias (or/c 'start-only 'start 'none 'end 'end-only)] [start exact-nonnegative-integer?] [end (or/c exact-nonnegative-integer? 'same) 'same] diff --git a/collects/tests/gracket/editor.rktl b/collects/tests/gracket/editor.rktl index 7551cca2f1..7486250afd 100644 --- a/collects/tests/gracket/editor.rktl +++ b/collects/tests/gracket/editor.rktl @@ -539,7 +539,7 @@ (send t end-edit-sequence) (send t undo) (st "" t get-text)) - + ;; ---------------------------------------- (report-errs) diff --git a/collects/tests/gracket/wxme.rkt b/collects/tests/gracket/wxme.rkt index c436b39fb9..aea0a7c6af 100644 --- a/collects/tests/gracket/wxme.rkt +++ b/collects/tests/gracket/wxme.rkt @@ -15,42 +15,42 @@ "test-editor-admin.ss" mred/private/wxme/stream mred/private/wxme/keymap - mred/private/wxme/editor-snip) + mred/private/wxme/editor-snip + (for-syntax racket/base)) (define wrong-cnt 0) (define test-cnt 0) -(define (expect v v2) +(define-syntax (expect stx) + (syntax-case stx () + [(_ a b) + #`(expect/proc #,(syntax-line stx) a b)])) + +(define (expect/proc line v v2) (set! test-cnt (add1 test-cnt)) (unless (equal? v v2) (set! wrong-cnt (add1 wrong-cnt)) - (printf "EXPECTED ~s:\n" v2)) - v) - -(define (show v) - (print v) - (newline)) - -(define (expect* v v2) - (if (equal? v v2) - (set! test-cnt (add1 test-cnt)) - (show (expect v v2)))) + (fprintf (current-error-port) + "FAILED: line ~a\nexpected: ~s\n got: ~s\n" + line + v2 + v))) (define (done) (printf "\n~a tests\n" test-cnt) (if (zero? wrong-cnt) (printf "all passed\n") - (printf "~s FAILED\n" wrong-cnt))) + (fprintf (current-error-port) "~s FAILED\n" wrong-cnt))) ;; ---------------------------------------- ;; String snips and lines (define s (make-object string-snip% "helko")) (send s insert "cat " 4 2) -(send s get-text 0 (send s get-count)) +(void (send s get-text 0 (send s get-count))) (send s set-flags (cons 'invisible (send s get-flags))) -(send s get-flags) -(send (send (get-the-snip-class-list) find "wxtext") get-classname) +(void (send s get-flags)) +(void (send (send (get-the-snip-class-list) find "wxtext") get-classname)) (define root-box (box mline-NIL)) (define m20 (mline-insert #f root-box #t)) @@ -144,8 +144,8 @@ (mline-delete i root-box) (mline-check-consistent (unbox root-box))) (cdr added)) - (show (expect (mline-next (car added)) #f)) - (show (expect (mline-prev (car added)) #f)) + (expect (mline-next (car added)) #f) + (expect (mline-prev (car added)) #f) (expect (unbox root-box) (car added))) @@ -158,7 +158,7 @@ (expect (send d1 equal? d2) #t) (send d1 set-underlined-on #t) (expect (send d1 equal? d2) #f) -(send d2 collapse d1) +(void (send d2 collapse d1)) (expect (send d2 get-underlined-on) #t) (send d2 set-underlined-on #f) (send d1 copy d2) @@ -411,26 +411,26 @@ [pos 0]) (unless (null? s+c) (let ([p (send t get-snip-position (caar s+c))]) - (expect* p pos) + (expect p pos) (let ([p2 (box 0)]) (when graphics? (if (send t get-snip-position-and-location (caar s+c) p2 x y) - (expect* (unbox p2) pos) - (show (expect #f #t)))) + (expect (unbox p2) pos) + (expect #f #t))) (loop (cdr s+c) (+ pos (cdar s+c)))))))) (for-each (lambda (before) (let loop ([pos 0][s+c snips+counts][snip-pos 0]) (if (null? s+c) - (show (expect pos (add1 (send t last-position)))) + (expect pos (add1 (send t last-position))) (let* ([s-pos (box 0)] [s (send t find-snip pos before s-pos)]) (let ([es (if (and (= pos 0) (eq? before 'before-or-none)) #f (caar s+c))]) - (expect* s es) - (expect* (unbox s-pos) snip-pos) + (expect s es) + (expect (unbox s-pos) snip-pos) (let ([next? (= pos (+ snip-pos (cdar s+c)))]) (loop (add1 pos) (if next? @@ -453,10 +453,10 @@ (car prev)) (caar s+c))] [ep (if end? (if es prev-snip-pos 0) snip-pos)]) - (expect* s es) - (expect* (unbox s-pos) ep) + (expect s es) + (expect (unbox s-pos) ep) (if end? - (show (expect pos (send t last-position))) + (expect pos (send t last-position)) (let ([next? (= (add1 pos) (+ snip-pos (cdar s+c)))]) (loop (add1 pos) (if next? @@ -478,30 +478,29 @@ (send t set-admin (new test-editor-admin%)) (define (check-simple-locations pl pt pr pb) - (list - (expect (let ([x (box 0.0)] [y (box 0.0)]) - (list (begin - (send t position-location 1 x y) - (list (unbox x) (unbox y))) - (begin - (send t position-location 1 x y #f) - (list (unbox x) (unbox y))))) - (list (list (+ pl 10.0) (+ pt 0.0)) - (list (+ pl 10.0) (+ pt 10.0)))) - (expect (let ([x (box 0.0)] [y (box 0.0)]) - (list (begin - (send t position-location 14 x y) - (list (unbox x) (unbox y))) - (begin - (send t position-location 14 x y #f) - (list (unbox x) (unbox y))))) - (list (list (+ pl 20.0) (+ pt 11.0)) - (list (+ pl 20.0) (+ pt 21.0)))) - (expect (let ([w (box 0.0)] [h (box 0.0)]) - (send t get-extent w h) - (list (unbox w) (unbox h))) - (list (+ 192.0 pl pr) - (+ 22.0 pt pb))))) + (expect (let ([x (box 0.0)] [y (box 0.0)]) + (list (begin + (send t position-location 1 x y) + (list (unbox x) (unbox y))) + (begin + (send t position-location 1 x y #f) + (list (unbox x) (unbox y))))) + (list (list (+ pl 10.0) (+ pt 0.0)) + (list (+ pl 10.0) (+ pt 10.0)))) + (expect (let ([x (box 0.0)] [y (box 0.0)]) + (list (begin + (send t position-location 14 x y) + (list (unbox x) (unbox y))) + (begin + (send t position-location 14 x y #f) + (list (unbox x) (unbox y))))) + (list (list (+ pl 20.0) (+ pt 11.0)) + (list (+ pl 20.0) (+ pt 21.0)))) + (expect (let ([w (box 0.0)] [h (box 0.0)]) + (send t get-extent w h) + (list (unbox w) (unbox h))) + (list (+ 192.0 pl pr) + (+ 22.0 pt pb)))) (check-simple-locations 0 0 0 0) (send t set-padding 5.0 8.0 11.0 13.0) @@ -562,20 +561,20 @@ (send t set-max-width 71.0) (define (check-ge&h-flow) - (expect* (send t last-line) 6) - (expect* (send t line-start-position 0) 0) - (expect* (send t line-start-position 1) 3) - (expect* (send t line-start-position 2) 7) - (expect* (send t line-start-position 3) 12) - (expect* (send t line-start-position 4) 18) - (expect* (send t line-start-position 5) 23) - (expect* (send t line-start-position 6) 27) - (expect* (send t last-paragraph) 1) - (expect* (send t paragraph-start-position 0) 0) - (expect* (send t paragraph-end-position 0) 11) - (expect* (send t paragraph-start-position 1) 12) - (expect* (send t paragraph-end-position 1) 31) - (expect* (send t paragraph-start-position 2) 31) + (expect (send t last-line) 6) + (expect (send t line-start-position 0) 0) + (expect (send t line-start-position 1) 3) + (expect (send t line-start-position 2) 7) + (expect (send t line-start-position 3) 12) + (expect (send t line-start-position 4) 18) + (expect (send t line-start-position 5) 23) + (expect (send t line-start-position 6) 27) + (expect (send t last-paragraph) 1) + (expect (send t paragraph-start-position 0) 0) + (expect (send t paragraph-end-position 0) 11) + (expect (send t paragraph-start-position 1) 12) + (expect (send t paragraph-end-position 1) 31) + (expect (send t paragraph-start-position 2) 31) (void)) (check-ge&h-flow) @@ -609,8 +608,8 @@ (list len)))]) (for/fold ([pos 0]) ([i (in-range (add1 (send t last-line)))] [len (in-list lens)]) - (expect* (send t line-start-position i #f) pos) - (expect* (send t line-end-position i #f) (+ pos len)) + (expect (send t line-start-position i #f) pos) + (expect (send t line-end-position i #f) (+ pos len)) (+ pos len)))) (for-each @@ -656,6 +655,7 @@ (send t delete 0 3) (send t delete (- (send t last-position) 4) (send t last-position)) (send t end-edit-sequence) + (expect (send t get-text) "you like\ngreen eggs and ") (send t delete 0 4) (expect (send t get-text) "like\ngreen eggs and ") @@ -668,15 +668,15 @@ (define fbo (make-object editor-stream-out-bytes-base%)) (expect (send fbo tell) 0) -(send fbo write-bytes #"abc") +(expect (send fbo write-bytes #"abc") (void)) (expect (send fbo tell) 3) (expect (send fbo get-bytes) #"abc") (send fbo seek 2) -(send fbo write-bytes #"012345" 1 4) +(expect (send fbo write-bytes #"012345" 1 4) (void)) (expect (send fbo tell) 5) (expect (send fbo get-bytes) #"ab123") (expect (send fbo bad?) #f) -(send fbo write '(#\o #\l #\d)) +(expect (send fbo write '(#\o #\l #\d)) (void)) (expect (send fbo get-bytes) #"ab123old") ;; ---------------------------------------- @@ -685,14 +685,14 @@ (define fbi (make-object editor-stream-in-bytes-base% #"ab123old")) (define ibuf (make-bytes 3)) (expect (send fbi tell) 0) -(send fbi read-bytes ibuf) +(expect (send fbi read-bytes ibuf) 3) (expect ibuf #"ab1") (expect (send fbi tell) 3) (send fbi seek 2) -(send fbi read-bytes ibuf 1 2) +(expect (send fbi read-bytes ibuf 1 2) 1) (expect ibuf #"a11") (send fbi skip 2) -(send fbi read-bytes ibuf 0 2) +(expect (send fbi read-bytes ibuf 0 2) 2) (expect ibuf #"ol1") (expect (send fbi bad?) #f) @@ -709,7 +709,7 @@ (expect (send fbo2 get-bytes) #"\n2 2.0") (expect (send fo tell) 2) (send fo jump-to 0) -(send fo put 3) +(void (send fo put 3)) (send fo jump-to 2) (expect (send fbo2 get-bytes) #"\n3 2.0") (void (send fo put #"hi")) @@ -850,10 +850,10 @@ (let* ([s (send (send t find-snip pos 'after) get-style)] [c (send s get-foreground)] [f (send s get-font)]) - (expect* (send c red) r) - (expect* (send c green) g) - (expect* (send c blue) b) - (expect* (send f get-weight) w))) + (expect (send c red) r) + (expect (send c green) g) + (expect (send c blue) b) + (expect (send f get-weight) w))) (send t erase) (send t insert "red\nblue") @@ -877,34 +877,34 @@ (check-color 4 0 0 255 'normal) (define (check-random-delta d) - (expect* (send d get-alignment-on) 'top) - (expect* (send d get-alignment-off) 'base) - (expect* (send (send d get-background-add) get-r) 25) - (expect* (send (send d get-background-add) get-g) 25) - (expect* (send (send d get-background-add) get-b) 25) - (expect* (send (send d get-background-mult) get-r) 0.5) - (expect* (send (send d get-background-mult) get-g) 0.5) - (expect* (send (send d get-background-mult) get-b) 0.5) - (expect* (send (send d get-foreground-add) get-r) 50) - (expect* (send (send d get-foreground-add) get-g) 50) - (expect* (send (send d get-foreground-add) get-b) 50) - (expect* (send (send d get-foreground-mult) get-r) 0.6) - (expect* (send (send d get-foreground-mult) get-g) 0.6) - (expect* (send (send d get-foreground-mult) get-b) 0.6) - (expect* (send d get-face) "Purty") - (expect* (send d get-family) 'decorative) - (expect* (send d get-size-in-pixels-on) #t) - (expect* (send d get-size-in-pixels-off) #f) - (expect* (send d get-smoothing-off) 'smoothed) - (expect* (send d get-smoothing-on) 'base) - (expect* (send d get-style-on) 'italic) - (expect* (send d get-style-off) 'base) - (expect* (send d get-transparent-text-backing-on) #t) - (expect* (send d get-transparent-text-backing-off) #f) - (expect* (send d get-underlined-off) #t) - (expect* (send d get-underlined-on) #f) - (expect* (send d get-weight-on) 'light) - (expect* (send d get-weight-off) 'base)) + (expect (send d get-alignment-on) 'top) + (expect (send d get-alignment-off) 'base) + (expect (send (send d get-background-add) get-r) 25) + (expect (send (send d get-background-add) get-g) 25) + (expect (send (send d get-background-add) get-b) 25) + (expect (send (send d get-background-mult) get-r) 0.5) + (expect (send (send d get-background-mult) get-g) 0.5) + (expect (send (send d get-background-mult) get-b) 0.5) + (expect (send (send d get-foreground-add) get-r) 50) + (expect (send (send d get-foreground-add) get-g) 50) + (expect (send (send d get-foreground-add) get-b) 50) + (expect (send (send d get-foreground-mult) get-r) 0.6) + (expect (send (send d get-foreground-mult) get-g) 0.6) + (expect (send (send d get-foreground-mult) get-b) 0.6) + (expect (send d get-face) "Purty") + (expect (send d get-family) 'decorative) + (expect (send d get-size-in-pixels-on) #t) + (expect (send d get-size-in-pixels-off) #f) + (expect (send d get-smoothing-off) 'smoothed) + (expect (send d get-smoothing-on) 'base) + (expect (send d get-style-on) 'italic) + (expect (send d get-style-off) 'base) + (expect (send d get-transparent-text-backing-on) #t) + (expect (send d get-transparent-text-backing-off) #f) + (expect (send d get-underlined-off) #t) + (expect (send d get-underlined-on) #f) + (expect (send d get-weight-on) 'light) + (expect (send d get-weight-off) 'base)) (let ([d (new style-delta%)]) (send d set-alignment-on 'top) @@ -1089,8 +1089,8 @@ (send kevt set-key-code #\m) (send kevt set-shift-down #f) (send km set-grab-key-function (lambda (str km-in ed evt) - (expect* km-in km) - (expect* evt kevt) + (expect km-in km) + (expect evt kevt) (set! hit (list str ed)) #t)) (expect (send km handle-key-event 'obj kevt) #t) @@ -1099,16 +1099,16 @@ (expect (send km handle-key-event 'obj kevt) #t) (expect hit '(#f obj)) (send km set-grab-key-function (lambda (str km-in ed evt) - (expect* str "letter-m") - (expect* ed 'obj2) + (expect str "letter-m") + (expect ed 'obj2) (set! hit 'nope) #f)) (send kevt set-key-code #\m) (expect (send km handle-key-event 'obj2 kevt) #t) (expect hit #\m) (send km set-grab-key-function (lambda (str km-in ed evt) - (expect* str #f) - (expect* ed 'obj3) + (expect str #f) + (expect ed 'obj3) (set! hit 'nope) #f)) (send kevt set-key-code #\p) @@ -1315,11 +1315,11 @@ (expect (send pb find-snip 15.0 20.0) ss1) (expect (send pb find-snip 35.0 10.0) ss2) (expect (send pb find-first-snip) ss2) -(send pb delete) "delete" +(send pb delete) ; "delete" (expect (send pb find-first-snip) ss1) (expect (send pb find-snip 15.0 20.0) ss1) (expect (send pb find-snip 35.0 10.0) #f) -(send pb undo) "undo" +(send pb undo) ; "undo" (expect (send pb find-first-snip) ss2) (expect (send pb find-snip 35.0 10.0) ss2) (expect (let ([x (box 0.0)] [y (box 0.0)]) @@ -1364,6 +1364,36 @@ (expect (send (mk) get-filename) (send copy-is get-filename))) + +;; ---------------------------------------- +;; get-extend-start-position and +;; get-extend-end-position + +(let ([t (new text%)]) + (send t insert (make-string 40 #\a)) + (send t set-position 10 20) + + (expect (send t get-start-position) 10) + (expect (send t get-end-position) 20) + (expect (send t get-extend-start-position) 10) + (expect (send t get-extend-end-position) 20) + + (send t set-anchor #t) + (send t set-position 5 25) + + (expect (send t get-start-position) 5) + (expect (send t get-end-position) 25) + (expect (send t get-extend-start-position) 5) + (expect (send t get-extend-end-position) 25) + + (send t set-anchor #t) + (send t set-position 0 30 #f #t 'default #t) + + (expect (send t get-start-position) 0) + (expect (send t get-end-position) 30) + (expect (send t get-extend-start-position) 5) + (expect (send t get-extend-end-position) 25)) + ;; ---------------------------------------- (done)