414 lines
16 KiB
Racket
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))])))
|