misc-deps
/
racket-ansi
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Introduce mark stickiness, and explicit mark types

This commit is contained in:
Tony Garnock-Jones 2014-12-20 12:52:35 -05:00
parent 4251c81fdb
commit e66e2fba4a
2 changed files with 99 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
ansi/buffer.rkt
View File

@ -3,6 +3,8 @@
(require "rope.rkt") (require "rope.rkt")
(require "search.rkt") (require "search.rkt")
(define main-mark-type (mark-type "main" 'right))
(struct buffer ([rope #:mutable] (struct buffer ([rope #:mutable]
[pos #:mutable] [pos #:mutable]
) #:transparent) ) #:transparent)
@ -23,11 +25,11 @@
(define (buffer-move-by! buf delta) (define (buffer-move-by! buf delta)
(buffer-move-to! buf (+ (buffer-pos buf) delta))) (buffer-move-to! buf (+ (buffer-pos buf) delta)))
(define (buffer-mark! buf [mark 'mark] #:position [pos (buffer-pos buf)] #:value [value #t]) (define (buffer-mark! buf [mtype main-mark-type] #:position [pos (buffer-pos buf)] #:value [value #t])
(buffer-lift0 replace-mark buf mark pos value)) (buffer-lift0 replace-mark buf mtype pos value))
(define (buffer-search* buf start-pos forward? move? find-delta) (define (buffer-search* buf start-pos forward? move? find-delta)
(define-values (l _marks r) (rope-split (buffer-rope buf) start-pos)) (define-values (l r) (rope-split (buffer-rope buf) start-pos))
(define delta (find-delta (if forward? r l))) (define delta (find-delta (if forward? r l)))
(define new-pos (+ start-pos (cond [(not delta) 0] [forward? delta] [else (- delta)]))) (define new-pos (+ start-pos (cond [(not delta) 0] [forward? delta] [else (- delta)])))
(when delta (when delta
@ -69,12 +71,12 @@
;; will end up at a configurable percentage of the way down the ;; will end up at a configurable percentage of the way down the
;; window. ;; window.
;; ;;
;; Mark Location Buffer -> Buffer ;; MarkType Location Buffer -> Buffer
;; Ensures the given mark is sanely positioned as a top-of-window mark ;; Ensures the given mark is sanely positioned as a top-of-window mark
;; with respect to the given cursor position. ;; with respect to the given cursor position.
(define (frame-buffer! top-of-window-mark cursor-position window-height buf (define (frame-buffer! top-of-window-mtype cursor-position window-height buf
#:preferred-position-fraction [preferred-position-fraction 1/2]) #:preferred-position-fraction [preferred-position-fraction 1/2])
(define old-top-of-window-pos (find-next-mark-pos (buffer-rope buf) top-of-window-mark)) (define old-top-of-window-pos (find-next-mark-pos (buffer-rope buf) top-of-window-mtype))
(define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction)))) (define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction))))
(let loop ((pos (buffer-find buf "\n" #:forward? #f #:move? #f)) (let loop ((pos (buffer-find buf "\n" #:forward? #f #:move? #f))
(line-count 0) (line-count 0)
@ -85,7 +87,7 @@
[(<= pos old-top-of-window-pos) [(<= pos old-top-of-window-pos)
buf] buf]
[(= line-count window-height) [(= line-count window-height)
(buffer-mark! buf top-of-window-mark #:position new-top-of-window-pos)] (buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos)]
[else [else
(loop (buffer-find buf "\n" #:forward? #f #:move? #f #:position (- pos 1)) (loop (buffer-find buf "\n" #:forward? #f #:move? #f #:position (- pos 1))
(+ line-count 1) (+ line-count 1)

160
ansi/rope.rkt
View File

@ -23,6 +23,8 @@
rope-generator rope-generator
rope-seek rope-seek
(struct-out mark-type)
has-mark? has-mark?
find-next-mark find-next-mark
find-prev-mark find-prev-mark
@ -39,8 +41,16 @@
(module+ test (require rackunit racket/pretty)) (module+ test (require rackunit racket/pretty))
;; A Mark is a Symbol. Marks can be associated with a set of Any ;; A Stickiness is one of
;; values at each position in the rope. ;; -- 'left or
;; -- 'right
;; and indicates the side after a rope-split to which a mark with this
;; Stickiness adheres. What Finseth calls a "normal mark" has 'right
;; stickiness, and what he calls a "fixed mark" has 'left stickiness.
;; A MarkType is a (mark-type String Stickiness). MarkTypes can be
;; associated with a set of Any values at each position in the rope.
(struct mark-type (name stickiness) #:transparent)
;; A Strand is a (strand String Number Number), representing a ;; A Strand is a (strand String Number Number), representing a
;; substring of a string. ;; substring of a string.
@ -54,7 +64,7 @@
right ;; Rope or #f right ;; Rope or #f
size* ;; Number, total length of this rope size* ;; Number, total length of this rope
marks* ;; Set of Mark marks* ;; Set of Mark
mark-index ;; (Hasheq Mark (Hash Number (Setof Any))), marks in this span mark-index ;; (Hash Mark (Hash Number (Setof Any))), marks in this span
) #:transparent) ) #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -115,7 +125,7 @@
(define (empty-rope) #f) (define (empty-rope) #f)
(define (strand->rope t) (define (strand->rope t)
(rope t #f #f (strand-count t) (seteq) (hasheq))) (rope t #f #f (strand-count t) (set) (hash)))
(define (string->rope s) (define (string->rope s)
(strand->rope (string->strand s))) (strand->rope (string->strand s)))
@ -197,9 +207,9 @@
;; Searches from pos (inclusive) in the direction indicated. ;; Searches from pos (inclusive) in the direction indicated.
;; Pos points to a mark-position, not a character-position. ;; Pos points to a mark-position, not a character-position.
(define (find-mark r forward? mark start-pos) (define (find-mark r forward? mtype start-pos)
(define (search-here r start-pos) (define (search-here r start-pos)
(define marks (hash-ref (rope-mark-index r) mark #f)) (define marks (hash-ref (rope-mark-index r) mtype #f))
(define lo (rope-lo r)) (define lo (rope-lo r))
(if (not marks) (if (not marks)
#f #f
@ -213,7 +223,7 @@
candidate))))) candidate)))))
(define (search r start-pos) (define (search r start-pos)
(and r (and r
(set-member? (rope-marks r) mark) (set-member? (rope-marks r) mtype)
(let-values (((lo hi) (rope-lo+hi r))) (let-values (((lo hi) (rope-lo+hi r)))
(cond (cond
[(< start-pos lo) [(< start-pos lo)
@ -226,32 +236,32 @@
(search-here r (- start-pos lo))])))) (search-here r (- start-pos lo))]))))
(search r start-pos)) (search r start-pos))
(define (has-mark? r mark) (define (has-mark? r mtype)
(and r (set-member? (rope-marks r) mark))) (and r (set-member? (rope-marks r) mtype)))
(define (find-mark* r forward? mark start-pos) (define (find-mark* r forward? mtype start-pos)
(define maybe-pos+val (find-mark r forward? mark start-pos)) (define maybe-pos+val (find-mark r forward? mtype start-pos))
(if maybe-pos+val (if maybe-pos+val
(values (car maybe-pos+val) (cdr maybe-pos+val)) (values (car maybe-pos+val) (cdr maybe-pos+val))
(values #f #f))) (values #f #f)))
(define (find-next-mark r mark [pos 0]) (find-mark* r #t mark pos)) (define (find-next-mark r mtype [pos 0]) (find-mark* r #t mtype pos))
(define (find-prev-mark r mark [pos (rope-size r)]) (find-mark* r #f mark pos)) (define (find-prev-mark r mtype [pos (rope-size r)]) (find-mark* r #f mtype pos))
(define (find-next-mark-pos r mark [pos 0]) (define (find-next-mark-pos r mtype [pos 0])
(cond [(find-mark r #t mark pos) => car] [else #f])) (cond [(find-mark r #t mtype pos) => car] [else #f]))
(define (find-prev-mark-pos r mark [pos (rope-size r)]) (define (find-prev-mark-pos r mtype [pos (rope-size r)])
(cond [(find-mark r #f mark pos) => car] [else #f])) (cond [(find-mark r #f mtype pos) => car] [else #f]))
(define (mark-union h1 h2 offset) (define (mark-union h1 h2 offset)
(for/fold [(h h1)] [((pos val) (in-hash h2))] (hash-set h (+ offset pos) val))) (for/fold [(h h1)] [((pos val) (in-hash h2))] (hash-set h (+ offset pos) val)))
(define (find-all-marks r mark) (define (find-all-marks r mtype)
(define (walk r) (define (walk r)
(if (set-member? (rope-marks r) mark) (if (set-member? (rope-marks r) mtype)
(let-values (((lo hi) (rope-lo+hi r))) (let-values (((lo hi) (rope-lo+hi r)))
(mark-union (walk (rope-left r)) (mark-union (walk (rope-left r))
(mark-union (hash-ref (rope-mark-index r) mark (lambda () (hash))) (mark-union (hash-ref (rope-mark-index r) mtype (lambda () (hash)))
(walk (rope-right r)) (walk (rope-right r))
hi) hi)
lo)) lo))
@ -263,12 +273,12 @@
(when (not found?) (error what "Invalid position ~a~a" pos (extra))) (when (not found?) (error what "Invalid position ~a~a" pos (extra)))
r1) r1)
(define (add-mark-to-table old-marks mark pos value) (define (add-mark-to-table old-marks mtype pos value)
(define old-mark (hash-ref old-marks mark (lambda () (hash)))) (define old-mark (hash-ref old-marks mtype (lambda () (hash))))
(hash-set old-marks mark (hash-set old-mark pos value))) (hash-set old-marks mtype (hash-set old-mark pos value)))
(define (set-mark r0 mark position value) (define (set-mark r0 mtype position value)
(define r (splay-to-pos 'set-mark r0 position (lambda () (format " setting mark ~a" mark)))) (define r (splay-to-pos 'set-mark r0 position (lambda () (format " setting mark ~a" mtype))))
(reindex (reindex
(if (not r) (if (not r)
(rope (empty-strand) (rope (empty-strand)
@ -276,35 +286,35 @@
#f #f
'will-be-recomputed 'will-be-recomputed
'will-be-recomputed 'will-be-recomputed
(hasheq mark (hash position value))) (hash mtype (hash position value)))
(struct-copy rope r [mark-index (add-mark-to-table (rope-mark-index r) (struct-copy rope r [mark-index (add-mark-to-table (rope-mark-index r)
mark mtype
(- position (rope-lo r)) (- position (rope-lo r))
value)])))) value)]))))
(define (clear-mark r0 mark position) (define (clear-mark r0 mtype position)
(define r (splay-to-pos 'clear-mark r0 position (lambda () (format " clearing mark ~a" mark)))) (define r (splay-to-pos 'clear-mark r0 position (lambda () (format " clearing mark ~a" mtype))))
(and r (and r
(reindex (reindex
(struct-copy rope r (struct-copy rope r
[mark-index [mark-index
(let* ((old-marks (rope-mark-index r)) (let* ((old-marks (rope-mark-index r))
(old-mark (hash-ref old-marks mark (lambda () (hash))))) (old-mark (hash-ref old-marks mtype (lambda () (hash)))))
(define new-mark (hash-remove old-mark position)) (define new-mark (hash-remove old-mark position))
(if (hash-empty? new-mark) (if (hash-empty? new-mark)
(hash-remove old-marks mark) (hash-remove old-marks mtype)
(hash-set old-marks mark new-mark)))])))) (hash-set old-marks mtype new-mark)))]))))
(define (replace-mark r0 mark new-pos new-value) (define (replace-mark r0 mtype new-pos new-value)
(define pos (find-next-mark-pos r0 mark)) (define pos (find-next-mark-pos r0 mtype))
(when (not pos) (error 'replace-mark "Mark ~a not found" mark)) (when (not pos) (error 'replace-mark "Mark ~a not found" mtype))
(set-mark (clear-mark r0 mark pos) mark new-pos new-value)) (set-mark (clear-mark r0 mtype pos) mtype new-pos new-value))
(define (rope-size r) (define (rope-size r)
(if r (rope-size* r) 0)) (if r (rope-size* r) 0))
(define (rope-marks r) (define (rope-marks r)
(if r (rope-marks* r) (seteq))) (if r (rope-marks* r) (set)))
(define (reindex r) (define (reindex r)
(struct-copy rope r (struct-copy rope r
@ -313,7 +323,7 @@
(strand-count (rope-strand r)))] (strand-count (rope-strand r)))]
[marks* (set-union (rope-marks (rope-left r)) [marks* (set-union (rope-marks (rope-left r))
(rope-marks (rope-right r)) (rope-marks (rope-right r))
(list->seteq (hash-keys (rope-mark-index r))))])) (list->set (hash-keys (rope-mark-index r))))]))
(define (rope-split r0 position) (define (rope-split r0 position)
(define r (splay-to-pos 'rope-split r0 position)) (define r (splay-to-pos 'rope-split r0 position))
@ -321,25 +331,26 @@
(match-define (rope t rl rr size marks mark-index) r) (match-define (rope t rl rr size marks mark-index) r)
(define-values (lo hi) (rope-lo+hi r)) (define-values (lo hi) (rope-lo+hi r))
(define offset (- position lo)) (define offset (- position lo))
(define-values (left-index marks-at-split right-index) (define-values (left-index right-index) (partition-mark-index mark-index offset))
(partition-mark-index mark-index offset))
(define left-strand (substrand t 0 offset)) (define left-strand (substrand t 0 offset))
(define right-strand (substrand t offset)) (define right-strand (substrand t offset))
(values (if (strand-empty? left-strand) (values (if (strand-empty? left-strand)
rl rl
(reindex (rope left-strand rl #f 'will-be-recomputed (seteq) left-index))) (reindex (rope left-strand rl #f 'will-be-recomputed (set) left-index)))
marks-at-split
(if (strand-empty? right-strand) (if (strand-empty? right-strand)
rr rr
(reindex (rope right-strand #f rr 'will-be-recomputed (seteq) right-index))))) (reindex (rope right-strand #f rr 'will-be-recomputed (set) right-index)))))
(define (partition-mark-index index offset) (define (partition-mark-index index offset)
(for*/fold [(l (hasheq)) (m (hasheq)) (r (hasheq))] (for*/fold [(l (hash)) (r (hash))]
[((mark posvals) (in-hash index)) [((mtype posvals) (in-hash index))
((pos val) (in-hash posvals))] ((pos val) (in-hash posvals))]
(values (if (< pos offset) (add-mark-to-table l mark pos val) l) (values (if (or (< pos offset) (and (= pos offset) (eq? (mark-type-stickiness mtype) 'left)))
(if (= pos offset) (hash-set m mark (set-add (hash-ref m mark (set)) val)) m) (add-mark-to-table l mtype pos val)
(if (> pos offset) (add-mark-to-table r mark (- pos offset) val) r)))) l)
(if (or (> pos offset) (and (= pos offset) (eq? (mark-type-stickiness mtype) 'right)))
(add-mark-to-table r mtype (- pos offset) val)
r))))
(define (rope-append rl0 rr0) (define (rope-append rl0 rr0)
(cond (cond
@ -354,7 +365,7 @@
(let ((merged-index (merge-mark-indexes (rope-mark-index rl) (let ((merged-index (merge-mark-indexes (rope-mark-index rl)
(rope-mark-index rr) (rope-mark-index rr)
(strand-count (rope-strand rl))))) (strand-count (rope-strand rl)))))
(reindex (rope t (rope-left rl) (rope-right rr) 'will-be-recomputed (seteq) merged-index))) (reindex (rope t (rope-left rl) (rope-right rr) 'will-be-recomputed (set) merged-index)))
(replace-right rl rr))])) (replace-right rl rr))]))
(define (rope-concat rs) (define (rope-concat rs)
@ -362,9 +373,9 @@
(define (merge-mark-indexes li ri offset) (define (merge-mark-indexes li ri offset)
(for*/fold [(i li)] (for*/fold [(i li)]
[((mark posvals) (in-hash ri)) [((mtype posvals) (in-hash ri))
((pos val) (in-hash posvals))] ((pos val) (in-hash posvals))]
(add-mark-to-table i mark (+ pos offset) val))) (add-mark-to-table i mtype (+ pos offset) val)))
(define (subrope* r0 [lo0 #f] [hi0 #f]) (define (subrope* r0 [lo0 #f] [hi0 #f])
(define lo (if (not lo0) (define lo (if (not lo0)
@ -432,38 +443,47 @@
(check-equal? (rope->string r) text) (check-equal? (rope->string r) text)
(loop (- n 1) r))) (loop (- n 1) r)))
(let*-values (((r) (set-mark (rope-concat rope-pieces) 'mark 9 "original")) (define mtype1 (mark-type "Mark1" 'left))
(define mtype2 (mark-type "Mark2" 'right))
(let*-values (((r) (set-mark (rope-concat rope-pieces) mtype1 9 "original"))
((_) (check-equal? (rope->string r) text)) ((_) (check-equal? (rope->string r) text))
((pos val) (find-next-mark r 'mark)) ((pos val) (find-next-mark r mtype1))
((_) (check-equal? pos 9)) ((_) (check-equal? pos 9))
((_) (check-equal? val "original")) ((_) (check-equal? val "original"))
((r) (clear-mark r 'mark pos)) ((r) (clear-mark r mtype1 pos))
((_) (check-equal? (find-all-marks r 'mark) (hash))) ((_) (check-equal? (find-all-marks r mtype1) (hash)))
((pos val) (find-next-mark r 'mark)) ((pos val) (find-next-mark r mtype1))
((_) (check-false pos)) ((_) (check-false pos))
((_) (check-false val)) ((_) (check-false val))
((r) (set-mark r 'mark 9 "second")) ((r) (set-mark r mtype1 9 "second"))
((pos val) (find-next-mark r 'mark)) ((pos val) (find-next-mark r mtype1))
((_) (check-equal? pos 9)) ((_) (check-equal? pos 9))
((_) (check-equal? val "second")) ((_) (check-equal? val "second"))
((r) (set-mark r 'mark 6 "first")) ((r) (set-mark r mtype1 6 "first"))
((_) (check-equal? (find-all-marks r 'mark) (hash 6 "first" 9 "second"))) ((r) (set-mark r mtype2 6 "third"))
((pos val) (find-prev-mark r 'mark)) ((_) (check-equal? (find-all-marks r mtype1) (hash 6 "first" 9 "second")))
((_) (check-equal? (find-all-marks r mtype2) (hash 6 "third")))
((pos val) (find-prev-mark r mtype1))
((_) (check-equal? pos 9)) ((_) (check-equal? pos 9))
((_) (check-equal? val "second")) ((_) (check-equal? val "second"))
((pos val) (find-next-mark r 'mark)) ((pos val) (find-next-mark r mtype1))
((_) (check-equal? pos 6)) ((_) (check-equal? pos 6))
((_) (check-equal? val "first")) ((_) (check-equal? val "first"))
((l ms r) (rope-split r pos)) ((l r) (rope-split r pos))
((_) (check-equal? (find-all-marks r 'mark) (hash 3 "second"))) ((_) (check-equal? (find-all-marks r mtype1) (hash 3 "second")))
((_) (check-equal? ms (hasheq 'mark (set "first")))) ((_) (check-equal? (find-all-marks l mtype1) (hash 6 "first")))
((_) (check-equal? (find-all-marks r mtype2) (hash 0 "third")))
((_) (check-equal? (find-all-marks l mtype2) (hash)))
((_) (check-equal? (rope->string l) (substring text 0 6))) ((_) (check-equal? (rope->string l) (substring text 0 6)))
((_) (check-equal? (rope->string r) (substring text 6 (string-length text)))) ((_) (check-equal? (rope->string r) (substring text 6 (string-length text))))
((_) (check-equal? (rope-marks l) (seteq))) ((_) (check-equal? (rope-marks l) (set mtype1)))
((_) (check-equal? (rope-marks r) (seteq 'mark))) ((_) (check-equal? (rope-marks r) (set mtype1 mtype2)))
((l ms r) (rope-split r 3)) ((l r) (rope-split r 3))
((_) (check-equal? (find-all-marks r 'mark) (hash))) ((_) (check-equal? (find-all-marks r mtype1) (hash)))
((_) (check-equal? ms (hasheq 'mark (set "second")))) ((_) (check-equal? (find-all-marks l mtype1) (hash 3 "second")))
((_) (check-equal? (find-all-marks r mtype2) (hash)))
((_) (check-equal? (find-all-marks l mtype2) (hash 0 "third")))
((_) (check-equal? (rope->string l) (substring text 6 9))) ((_) (check-equal? (rope->string l) (substring text 6 9)))
((_) (check-equal? (rope->string r) (substring text 9 (string-length text))))) ((_) (check-equal? (rope->string r) (substring text 9 (string-length text)))))
(void))) (void)))