added get-extend-start-position and get-extend-end-position

added the extend-position method
adjusted the wxme.rkt test suite so that it only prints when tests fail

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)

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)))
 
   ;; ----------------------------------------
 

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]

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))
+    (fprintf (current-error-port)
-  v)
+             "FAILED: line ~a\nexpected: ~s\n     got: ~s\n" 
-
+             line
-(define (show v)
+             v2
-  (print v)
+             v)))
-  (newline))
-
-(define (expect* v v2)
-  (if (equal? v v2)
-      (set! test-cnt (add1 test-cnt))
-      (show (expect v v2))))
 
 (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)
+(void (send s get-flags))
-(send (send (get-the-snip-class-list) find "wxtext") get-classname)
+(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))
+  (expect (mline-next (car added)) #f)
-  (show (expect (mline-prev (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)
+                  (expect (unbox p2) pos)
-                  (show (expect #f #t))))
+                  (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 s es)
-               (expect* (unbox s-pos) snip-pos)
+               (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 s es)
-         (expect* (unbox s-pos) ep)
+         (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,7 +478,6 @@
 (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)
@@ -501,7 +500,7 @@
             (send t get-extent w h)
             (list (unbox w) (unbox h)))
           (list (+ 192.0 pl pr)
-                 (+ 22.0 pt pb)))))
+                (+ 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 last-line) 6)
-  (expect* (send t line-start-position 0) 0)
+  (expect (send t line-start-position 0) 0)
-  (expect* (send t line-start-position 1) 3)
+  (expect (send t line-start-position 1) 3)
-  (expect* (send t line-start-position 2) 7)
+  (expect (send t line-start-position 2) 7)
-  (expect* (send t line-start-position 3) 12)
+  (expect (send t line-start-position 3) 12)
-  (expect* (send t line-start-position 4) 18)
+  (expect (send t line-start-position 4) 18)
-  (expect* (send t line-start-position 5) 23)
+  (expect (send t line-start-position 5) 23)
-  (expect* (send t line-start-position 6) 27)
+  (expect (send t line-start-position 6) 27)
-  (expect* (send t last-paragraph) 1)
+  (expect (send t last-paragraph) 1)
-  (expect* (send t paragraph-start-position 0) 0)
+  (expect (send t paragraph-start-position 0) 0)
-  (expect* (send t paragraph-end-position 0) 11)
+  (expect (send t paragraph-end-position 0) 11)
-  (expect* (send t paragraph-start-position 1) 12)
+  (expect (send t paragraph-start-position 1) 12)
-  (expect* (send t paragraph-end-position 1) 31)
+  (expect (send t paragraph-end-position 1) 31)
-  (expect* (send t paragraph-start-position 2) 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-start-position i #f) pos)
-      (expect* (send t line-end-position i #f) (+ pos len))
+      (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 red) r)
-    (expect* (send c green) g)
+    (expect (send c green) g)
-    (expect* (send c blue) b)
+    (expect (send c blue) b)
-    (expect* (send f get-weight) w)))
+    (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-on) 'top)
-  (expect* (send d get-alignment-off) 'base)
+  (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-r) 25)
-  (expect* (send (send d get-background-add) get-g) 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-add) get-b) 25)
-  (expect* (send (send d get-background-mult) get-r) 0.5)
+  (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-g) 0.5)
-  (expect* (send (send d get-background-mult) get-b) 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-r) 50)
-  (expect* (send (send d get-foreground-add) get-g) 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-add) get-b) 50)
-  (expect* (send (send d get-foreground-mult) get-r) 0.6)
+  (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-g) 0.6)
-  (expect* (send (send d get-foreground-mult) get-b) 0.6)
+  (expect (send (send d get-foreground-mult) get-b) 0.6)
-  (expect* (send d get-face) "Purty") 
+  (expect (send d get-face) "Purty") 
-  (expect* (send d get-family) 'decorative)
+  (expect (send d get-family) 'decorative)
-  (expect* (send d get-size-in-pixels-on) #t)
+  (expect (send d get-size-in-pixels-on) #t)
-  (expect* (send d get-size-in-pixels-off) #f)
+  (expect (send d get-size-in-pixels-off) #f)
-  (expect* (send d get-smoothing-off) 'smoothed)
+  (expect (send d get-smoothing-off) 'smoothed)
-  (expect* (send d get-smoothing-on) 'base)
+  (expect (send d get-smoothing-on) 'base)
-  (expect* (send d get-style-on) 'italic)
+  (expect (send d get-style-on) 'italic)
-  (expect* (send d get-style-off) 'base)
+  (expect (send d get-style-off) 'base)
-  (expect* (send d get-transparent-text-backing-on) #t)
+  (expect (send d get-transparent-text-backing-on) #t)
-  (expect* (send d get-transparent-text-backing-off) #f)
+  (expect (send d get-transparent-text-backing-off) #f)
-  (expect* (send d get-underlined-off) #t)
+  (expect (send d get-underlined-off) #t)
-  (expect* (send d get-underlined-on) #f)
+  (expect (send d get-underlined-on) #f)
-  (expect* (send d get-weight-on) 'light)
+  (expect (send d get-weight-on) 'light)
-  (expect* (send d get-weight-off) 'base))
+  (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 km-in km)
-                                 (expect* evt kevt)
+                                 (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 str "letter-m")
-                                 (expect* ed 'obj2)
+                                 (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 str #f)
-                                 (expect* ed 'obj3)
+                                 (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)