add all-string-snips<%> and all-string-snips-mixin

This is pulled out of DrRacket, mostly just to be able to add test cases

Author: rfindler

gui-doc/scribblings/framework/text.scrbl

@@ -477,6 +477,33 @@
   }
 }
 
+@definterface[text:all-string-snips<%> ()]{
+ @defmethod[(all-string-snips?) boolean?]{
+  Returns @racket[#t] if all of the snips in the @racket[text%] object
+  are @racket[string-snip%]s.
+
+  This method usually returns quickly, tracking changes to the editor
+  to update internal state. But if a non-@racket[string-snip%] is deleted,
+  then the next call to @method[text:all-string-snips<%> all-string-snips?]
+  traverses the entire content to search to see if there are other
+  non-@racket[string-snip%]s.
+ }
+}
+
+@defmixin[text:all-string-snips-mixin (text%) (text:all-string-snips<%>)]{
+ @defmethod[#:mode augment (on-insert [start exact-nonnegative-integer?]
+                                      [len exact-nonnegative-integer?]) void?]{
+  Checks to see if there were any non-@racket[string-snip%]s inserted
+  in the given range and, if so, updates the internal state.
+ }
+
+  @defmethod[#:mode augment (after-delete [start exact-nonnegative-integer?]
+                                          [len exact-nonnegative-integer?]) void?]{
+  Checks to see if there were any non-@racket[string-snip%]s deleted
+  in the given range and, if so, updates the internal state.
+ }
+}
+
 @definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{
   Any object matching this interface can be searched.
 

gui-lib/framework/private/sig.rkt

@@ -188,6 +188,7 @@
      nbsp->space<%>
      column-guide<%>
      normalize-paste<%>
+     all-string-snips<%>
      delegate<%>
      wide-snip<%>
      searching<%>
@@ -229,6 +230,7 @@
      nbsp->space-mixin
      column-guide-mixin
      normalize-paste-mixin
+     all-string-snips-mixin
      wide-snip-mixin
      delegate-mixin
      searching-mixin

gui-lib/framework/private/text.rkt

@@ -4494,6 +4494,62 @@ designates the character that triggers autocompletion
 (define-struct saved-dc-state (smoothing pen brush font text-foreground-color text-mode))
 (define padding-dc (new bitmap-dc% [bitmap (make-screen-bitmap 1 1)]))
 
+(define all-string-snips<%>
+  (interface ()
+    all-string-snips?))
+  
+(define all-string-snips-mixin
+  (mixin ((class->interface text%)) (all-string-snips<%>)
+    (inherit find-first-snip find-snip)
+    
+    (define/private (all-string-snips?/slow)
+      (let loop ([s (find-first-snip)])
+        (cond
+          [(not s) #t]
+          [(is-a? s string-snip%) (loop (send s next))]
+          [else #f])))
+
+    (define/augment (after-insert start end)
+      (inner (void) after-insert start end)
+      
+      (when (equal? all-string-snips-state #t)
+        (let loop ([s (find-snip start 'after-or-none)]
+                   [i start])
+          (cond
+            [(not s) (void)]
+            [(not (< i end)) (void)]
+            [(is-a? s string-snip%)
+             (define size (send s get-count))
+             (loop (send s next) (+ i size))]
+            [else (set! all-string-snips-state #f)]))))
+    
+    (define/augment (on-delete start end)
+      (inner (void) on-delete start end)
+      (when (equal? all-string-snips-state #f)
+        (let loop ([s (find-snip start 'after-or-none)]
+                   [i start])
+          (cond
+            [(not s) (void)]
+            [(not (< i end)) (void)]
+            [(is-a? s string-snip%)
+             (define size (send s get-count))
+             (loop (send s next) (+ i size))]
+            [else (set! all-string-snips-state 'dont-know)]))))
+
+    
+    ;; (or/c #t #f 'dont-know)
+    (define all-string-snips-state #t)
+    (define/public (all-string-snips?)
+      (cond
+        [(boolean? all-string-snips-state)
+         all-string-snips-state]
+        [else
+         (define all-string-snips? (all-string-snips?/slow))
+         (set! all-string-snips-state all-string-snips?)
+         all-string-snips?]))
+    
+    (super-new)))
+  
 (define basic% (basic-mixin (editor:basic-mixin text%)))
 (define line-spacing% (line-spacing-mixin basic%))
 (define hide-caret/selection% (hide-caret/selection-mixin line-spacing%))

gui-lib/info.rkt

@@ -30,4 +30,4 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.10")
+(define version "1.11")

gui-test/framework/tests/text.rkt

@@ -252,6 +252,98 @@
             (and (false? pos) (is-a? edit pasteboard%)))))))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  all-string-snips<%>
+;;
+
+(test
+ 'all-string-snips<%>.1
+ (λ (x) (equal? x #t))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t all-string-snips?)))))
+
+(test
+ 'all-string-snips<%>.2
+ (λ (x) (equal? x #t))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t insert "xx")
+       (send t all-string-snips?)))))
+
+(test
+ 'all-string-snips<%>.3
+ (λ (x) (equal? x #t))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t insert "xx")
+       (send t delete 0 1)
+       (send t all-string-snips?)))))
+
+(test
+ 'all-string-snips<%>.4
+ (λ (x) (equal? x #t))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t insert "xx")
+       (send t delete 0 2)
+       (send t all-string-snips?)))))
+
+(test
+ 'all-string-snips<%>.5
+ (λ (x) (equal? x #f))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t insert (new snip%))
+       (send t all-string-snips?)))))
+
+(test
+ 'all-string-snips<%>.6
+ (λ (x) (equal? x #t))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t insert (new snip%))
+       (send t delete 0 1)
+       (send t all-string-snips?)))))
+
+(test
+ 'all-string-snips<%>.7
+ (λ (x) (equal? x #f))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t insert (new snip%))
+       (send t insert (new snip%))
+       (send t delete 0 1)
+       (send t all-string-snips?)))))
+
+(test
+ 'all-string-snips<%>.8
+ (λ (x) (equal? x #f))
+ (λ ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define t (new (text:all-string-snips-mixin text%)))
+       (send t insert (new snip%))
+       (send t insert "abcdef")
+       (send t insert (new snip%))
+       (send t delete 2 4)
+       (send t all-string-snips?)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  print-to-dc