racket-ansi/rmacs/buffer.rkt

414 lines
16 KiB
Racket

#lang racket/base
(provide (struct-out buffer-mark-type)
make-buffergroup
initialize-buffergroup!
buffer?
make-buffer
register-buffer!
lookup-buffer
unused-buffer-title
file->buffer
buffer-rename!
buffer-reorder!
buffer-next
buffer-prev
buffer-title
buffer-rope
buffer-group
buffer-editor
buffer-modeset
buffer-column
buffer-apply-modeset!
buffer-add-mode!
buffer-remove-mode!
buffer-toggle-mode!
buffer-size
buffer-start-of-line
buffer-end-of-line
buffer-mark-types
buffer-mark*
buffer-mark
buffer-mark-pos*
buffer-mark-pos
buffer-mark!
buffer-clear-mark!
buffer-move-mark!
buffer-move-mark-to-start-of-line!
buffer-move-mark-to-end-of-line!
buffer-region-split
buffer-region
buffer-region-update!
buffer-insert!
buffer-replace-contents!
buffer-search
buffer-findf
command?
command-selector
command-buffer
command-window
command-editor
(rename-out [make-command command])
invoke
define-key
define-command)
(require racket/match)
(require (for-syntax syntax/parse))
(require (for-syntax racket/base))
(require (only-in racket/string string-join))
(require (only-in racket/path normalize-path))
(require (only-in racket/file file->string))
(require "rope.rkt")
(require "search.rkt")
(require "circular-list.rkt")
(require "mode.rkt")
(require "keys.rkt")
(struct buffer-mark-type (kind ;; Symbol
window-id ;; Symbol
preserve? ;; Boolean
) #:prefab)
(struct buffergroup ([members #:mutable] ;; (CircularList Buffer)
[editor #:mutable] ;; (Option Editor), for bidirectional editor/group linkage
) #:prefab)
(struct buffer ([rope #:mutable]
[title #:mutable]
[group #:mutable] ;; (Option BufferGroup)
[modeset #:mutable] ;; ModeSet
) #:prefab)
(struct command (selector ;; Symbol
buffer ;; Buffer
window ;; (Option Window)
editor ;; Editor
keyseq ;; (Option Keyseq)
prefix-arg ;; Any
) #:prefab)
(define (make-buffergroup)
(buffergroup circular-empty #f))
(define (initialize-buffergroup! g editor)
(when (buffergroup-editor g)
(error 'initialize-buffergroup! "Duplicate initialization of buffergroup"))
(set-buffergroup-editor! g editor)
g)
(define (initial-contents-rope initial-contents)
(cond
[(string? initial-contents) (string->rope initial-contents)]
[(rope? initial-contents) initial-contents]
[(procedure? initial-contents) (initial-contents-rope (initial-contents))]
[else (error 'initial-contents-rope "Invalid initial-contents: ~v" initial-contents)]))
(define (make-buffer group ;; (Option BufferGroup)
title ;; String
#:initial-contents [initial-contents ""])
(register-buffer! group (buffer (initial-contents-rope initial-contents)
title
#f
kernel-modeset)))
(define (register-buffer! group buf)
(define old-group (buffer-group buf))
(when old-group
(set-buffergroup-members! old-group
(circular-list-remove buf (buffergroup-members old-group) eq?))
(set-buffer-group! buf #f))
(cond
[(not group) buf]
[(title->buffer* group (buffer-title buf)) #f]
[else
(set-buffer-group! buf group)
(set-buffergroup-members! group (circular-cons buf (buffergroup-members group)))
buf]))
(define (title->buffer* group title)
(and group
(circular-list-memf (lambda (b) (equal? (buffer-title b) title))
(buffergroup-members group))))
(define (buffer->buffer* group b)
(and group
(circular-list-memf (lambda (b1) (eq? b b1)) (buffergroup-members group))))
(define (lookup-buffer group title)
(cond [(title->buffer* group title) => circular-car] [else #f]))
(define (title-exists-in-group? group title)
(and (title->buffer* group title) #t))
(define (unused-buffer-title group context-pieces)
(define primary-piece (if (null? context-pieces) "*anonymous*" (car context-pieces)))
(define uniquifiers (if (null? context-pieces) '() (cdr context-pieces)))
(let search ((used '()) (remaining uniquifiers))
(define candidate
(if (null? used)
primary-piece
(format "~a<~a>" primary-piece (string-join used "/"))))
(if (title-exists-in-group? group candidate)
(if (pair? remaining)
(search (cons (car remaining) used) (cdr remaining))
(let search ((counter 2))
(define candidate (format "~a<~a>" primary-piece counter))
(if (title-exists-in-group? group candidate)
(search (+ counter 1))
candidate)))
candidate)))
;; (Option Group) Path -> String
(define (filename->unique-buffer-title group filename)
(define pieces (reverse (map path->string (explode-path filename))))
(if (not group)
(car pieces)
(unused-buffer-title group pieces)))
(define (file->buffer group filename)
(let* ((filename (normalize-path (simplify-path filename)))
(title (filename->unique-buffer-title group filename))
(b (make-buffer group title)))
(buffer-replace-contents! b (string->rope (file->string filename)))))
(define (buffer-rename! b new-title)
(if (title-exists-in-group? (buffer-group b) new-title)
#f
(begin (set-buffer-title! b new-title)
b)))
(define (buffer-reorder! b)
;; Reorders b to the top of the group as a side-effect
(register-buffer! (buffer-group b) b))
(define (buffer-next b)
(cond [(buffer->buffer* (buffer-group b) b) => (compose circular-car circular-list-rotate-forward)]
[else #f]))
(define (buffer-prev b)
(cond [(buffer->buffer* (buffer-group b) b) => (compose circular-car circular-list-rotate-backward)]
[else #f]))
(define (buffer-size buf) (rope-size (buffer-rope buf)))
(define (buffer-editor b)
(define g (buffer-group b))
(and g (buffergroup-editor g)))
(define (buffer-column buf pos-or-mtype)
;; TODO: count actual columns!
(define pos (->pos buf pos-or-mtype 'buffer-column))
(- pos (buffer-start-of-line buf pos)))
(define (buffer-apply-modeset! buf modeset)
(set-buffer-modeset! buf modeset))
(define (buffer-add-mode! buf mode)
(set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode)))
(define (buffer-remove-mode! buf mode)
(set-buffer-modeset! buf (modeset-remove-mode (buffer-modeset buf) mode)))
(define (buffer-toggle-mode! buf mode)
(set-buffer-modeset! buf (modeset-toggle-mode (buffer-modeset buf) mode)))
(define (clamp pos buf)
(max 0 (min (buffer-size buf) pos)))
(define (buffer-seek! buf pos)
(buffer-lift rope-seek buf (clamp pos buf)))
(define (buffer-start-of-line buf pos-or-mtype)
(buffer-findf buf pos-or-mtype (lambda (ch) (equal? ch #\newline)) #:forward? #f))
(define (buffer-end-of-line buf pos-or-mtype)
(buffer-findf buf pos-or-mtype (lambda (ch) (equal? ch #\newline)) #:forward? #t))
(define (->pos buf pos-or-mtype what)
(clamp (if (number? pos-or-mtype)
pos-or-mtype
(buffer-mark-pos buf pos-or-mtype what))
buf))
(define (buffer-mark-types buf)
(rope-marks (buffer-rope buf)))
(define (buffer-mark* buf mtype)
(find-mark (buffer-rope buf) mtype))
(define (buffer-mark buf mtype [what 'buffer-mark])
(or (buffer-mark* buf mtype)
(error what "Mark type ~v not found; available mark types ~v" mtype (buffer-mark-types buf))))
(define (buffer-mark-pos* buf mtype)
(find-mark-pos (buffer-rope buf) mtype))
(define (buffer-mark-pos buf mtype [what 'buffer-mark-pos])
(or (buffer-mark-pos* buf mtype)
(error what "Mark type ~v not found; available mark types ~v" mtype (buffer-mark-types buf))))
(define (buffer-mark! buf mtype pos-or-mtype #:value [value #t])
(buffer-lift replace-mark buf mtype (->pos buf pos-or-mtype 'buffer-mark!) value))
(define (buffer-clear-mark! buf mtype)
(define pos (buffer-mark-pos* buf mtype))
(if pos
(buffer-lift clear-mark buf mtype pos)
buf))
(define (buffer-move-mark! buf mtype delta)
(match-define (cons pos val) (buffer-mark buf mtype 'buffer-move-mark!))
(buffer-mark! buf mtype (+ pos delta) #:value val))
(define (buffer-move-mark-to-start-of-line! buf mtype)
(define pos (buffer-mark-pos buf mtype 'buffer-move-mark-to-start-of-line!))
(buffer-mark! buf mtype (buffer-start-of-line buf pos)))
(define (buffer-move-mark-to-end-of-line! buf mtype)
(define pos (buffer-mark-pos buf mtype 'buffer-move-mark-to-end-of-line!))
(buffer-mark! buf mtype (buffer-end-of-line buf pos)))
(define (buffer-region-split buf pm1 pm2)
(define p1 (->pos buf pm1 'buffer-region-split))
(define p2 (->pos buf pm2 'buffer-region-split))
(define lo (min p1 p2))
(define hi (max p1 p2))
(define-values (l mr) (rope-split (buffer-rope buf) lo))
(define-values (m r) (rope-split mr (- hi lo)))
(values l lo m hi r))
(define (buffer-region buf pm1 pm2)
(define-values (_l _lo m _hi _r) (buffer-region-split buf pm1 pm2))
m)
(define (transfer-marks ro rn)
(define mtypes-to-transfer
(for/list ((mtype (rope-marks ro))
#:when (buffer-mark-type-preserve? (mark-type-info mtype)))
mtype))
(for/fold [(rn rn)] [(mtype mtypes-to-transfer)]
(define pos (case (mark-type-stickiness mtype)
[(left) 0]
[(right) (rope-size rn)]))
(set-mark rn mtype pos #t)))
(define (buffer-region-update! buf pm1 pm2 updater)
(define-values (l lo old-m hi r) (buffer-region-split buf pm1 pm2))
(define new-m (transfer-marks old-m (updater old-m)))
(define delta (- (rope-size new-m) (rope-size old-m)))
(set-buffer-rope! buf (rope-append (rope-append l new-m) r))
buf)
(define (buffer-insert! buf pos-or-mtype content-rope)
(define pos (->pos buf pos-or-mtype 'buffer-insert!))
(define-values (l r) (rope-split (buffer-rope buf) pos))
(set-buffer-rope! buf (rope-append (rope-append l content-rope) r))
buf)
(define (buffer-replace-contents! buf content-rope)
(buffer-region-update! buf 0 (buffer-size buf) (lambda (_dontcare) content-rope)))
(define (buffer-search* buf start-pos-or-mtype forward? find-delta)
(define start-pos (->pos buf start-pos-or-mtype 'buffer-search*))
(define-values (l r) (rope-split (buffer-rope buf) start-pos))
(define delta (find-delta (if forward? r l)))
(and delta
(let ((new-pos (clamp (+ start-pos (cond [(not delta) 0]
[forward? delta]
[else (- delta (rope-size l))]))
buf)))
(buffer-seek! buf new-pos)
new-pos)))
(define (buffer-search buf start-pos-or-mtype needle #:forward? [forward? #t])
(buffer-search* buf start-pos-or-mtype forward?
(lambda (piece) (search-rope needle piece #:forward? forward?))))
(define (buffer-findf buf start-pos-or-mtype f #:forward? [forward? #t])
(buffer-search* buf start-pos-or-mtype forward?
(lambda (piece) (findf-in-rope f piece #:forward? forward?))))
(define (buffer-lift f buf . args)
(define new-rope (apply f (buffer-rope buf) args))
(set-buffer-rope! buf new-rope)
buf)
;;---------------------------------------------------------------------------
(define (make-command selector buffer-or-command
#:window [window #f]
#:editor [editor #f]
#:keyseq [keyseq #f]
#:prefix-arg [prefix-arg '#:default])
(define buffer (cond
[(buffer? buffer-or-command) buffer-or-command]
[(command? buffer-or-command) (command-buffer buffer-or-command)]))
(command selector buffer window (or editor (buffer-editor buffer)) keyseq prefix-arg))
(define (invoke cmd)
(match-define (command selector buf _ _ keyseq _) cmd)
(define handler (modeset-lookup-command (buffer-modeset buf) selector))
(when (not handler)
(error 'invoke "Unhandled command ~a (key sequence: ~a)"
selector
(if keyseq (keyseq->keyspec keyseq) "N/A")))
(handler cmd))
(define-syntax-rule (define-key mode-exp keyspec-exp command-symbol)
(void (mode-keymap-bind! mode-exp keyspec-exp 'command-symbol)))
(define-syntax define-command
(lambda (stx)
(syntax-parse stx
[(_ mode-exp
(selector buffer
(~or (~optional (~seq #:next-method next-method)
#:defaults ([next-method #'nm])
#:name "#:next-method")
(~optional (~seq #:command cmd)
#:defaults ([cmd #'cmd])
#:name "#:command")
(~optional (~seq #:selector self-selector)
#:defaults ([self-selector #'self])
#:name "#:selector")
(~optional (~seq #:window window)
#:defaults ([window #'win])
#:name "#:window")
(~optional (~seq #:editor editor)
#:defaults ([editor #'ed])
#:name "#:editor")
(~optional (~seq #:keyseq keyseq)
#:defaults ([keyseq #'keyseq])
#:name "#:keyseq")
(~optional (~seq #:prefix-arg
(~or (~seq [prefix-arg prefix-default prefix-prefix])
(~seq [prefix-arg prefix-default])
prefix-arg))
#:defaults ([prefix-arg #'pa]
[prefix-default #''#:default]
[prefix-prefix #''#:prefix])
#:name "#:prefix-arg"))
...)
(~seq #:bind-key bind-keyspec-exps) ...
body ...)
#`(let ((mode mode-exp))
(mode-define-command! mode
'selector
(lambda (cmd next-method)
(match-define (command self-selector
buffer
window
editor
keyseq
prefix-arg) cmd)
(let ((prefix-arg (match prefix-arg
['#:default prefix-default]
['#:prefix prefix-prefix]
[_ prefix-arg])))
body ...)))
#,@(for/list ((bind-keyspec-exp (syntax->list #'(bind-keyspec-exps ...))))
#`(mode-keymap-bind! mode #,bind-keyspec-exp 'selector))
(void))])))