From 8d92bb8c1306d0ca6c056f640eb04c81a76b1d09 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Sun, 28 Dec 2014 01:05:12 -0500
Subject: [PATCH] Fix edge condition in clear-mark

---
 rmacs/rope.rkt | 47 ++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 36 insertions(+), 11 deletions(-)

diff --git a/rmacs/rope.rkt b/rmacs/rope.rkt
index a62115f..c56460e 100644
--- a/rmacs/rope.rkt
+++ b/rmacs/rope.rkt
@@ -308,17 +308,23 @@
                                                           value)]))))
 
 (define (clear-mark r0 mtype position)
-  (define r (splay-to-pos 'clear-mark r0 position (lambda () (format " clearing mark ~a" mtype))))
-  (and r
-       (reindex
-        (struct-copy rope r
-                     [mark-index
-                      (let* ((old-marks (rope-mark-index r))
-                             (old-mark (hash-ref old-marks mtype (lambda () (hash)))))
-                        (define new-mark (hash-remove old-mark (- position (rope-lo r))))
-                        (if (hash-empty? new-mark)
-                            (hash-remove old-marks mtype)
-                            (hash-set old-marks mtype new-mark)))]))))
+  (let walk ((r (splay-to-pos 'clear-mark
+                              r0
+                              position
+                              (lambda () (format " clearing mark ~a" mtype)))))
+    (if (not (has-mark? r mtype))
+        r
+        (reindex
+         (struct-copy rope r
+                      [left (walk (rope-left r))]
+                      [right (walk (rope-right r))]
+                      [mark-index
+                       (let* ((old-marks (rope-mark-index r))
+                              (old-mark (hash-ref old-marks mtype (lambda () (hash)))))
+                         (define new-mark (hash-remove old-mark (- position (rope-lo r))))
+                         (if (hash-empty? new-mark)
+                             (hash-remove old-marks mtype)
+                             (hash-set old-marks mtype new-mark)))])))))
 
 (define (replace-mark r0 mtype new-pos new-value)
   (define pos (find-mark-pos r0 mtype))
@@ -559,4 +565,23 @@
                 ((_) (check-equal? (rope-marks l) (seteq)))
                 ((_) (check-equal? (rope-marks r) (seteq mtype2))))
     (void))
+
+  (let*-values (((xs) (make-string 128 #\x))
+                ((r) (string->rope (string-append "hello " xs)))
+                ((r) (set-mark r mtype2 3 #t))
+                ((l mr) (rope-split r (find-mark-pos r mtype2)))
+                ((m r) (rope-split mr 1))
+                ((_) (check-equal? (rope->string l) "hel"))
+                ((_) (check-equal? (rope->string m) "l"))
+                ((_) (check-equal? (rope->string r) (string-append "o " xs)))
+                ((_) (check-equal? (rope-marks l) (seteq)))
+                ((_) (check-equal? (rope-marks m) (seteq mtype2)))
+                ((_) (check-equal? (rope-marks r) (seteq)))
+                ((new-m) (set-mark (empty-rope) mtype2 0 #t))
+                ((r) (rope-append (rope-append l new-m) r))
+                ((_) (check-equal? (rope->string r) (string-append "helo " xs)))
+                ((_) (check-equal? (find-mark-pos r mtype2) 3))
+                ((r) (clear-mark r mtype2 (find-mark-pos r mtype2)))
+                ((_) (check-equal? (find-mark-pos r mtype2) #f)))
+    (void))
   )