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

Split out rmacs into its own package.

This commit is contained in:
Tony Garnock-Jones 2015-01-01 17:38:28 -05:00
parent 9813d6dfe0
commit e299aea04c
23 changed files with 1 additions and 3695 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -1,5 +1,5 @@
PACKAGENAME=ansi PACKAGENAME=ansi
COLLECTS=ansi rmacs COLLECTS=ansi
all: setup all: setup

4
rmacs/TODO
View File

@ -1,4 +0,0 @@
Make it reloadable
Catch and handle SIGWINCH.
See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html

18
rmacs/api.rkt
View File

@ -1,18 +0,0 @@
#lang racket/base
;; API for writing modes/commands/etc.
(require "mode.rkt")
(require "editor.rkt")
(require "buffer.rkt")
(require "keys.rkt")
(require "rope.rkt")
(require "window.rkt")
(require "minibuf.rkt")
(provide (all-from-out "mode.rkt"
"editor.rkt"
"buffer.rkt"
"keys.rkt"
"rope.rkt"
"window.rkt"
"minibuf.rkt"))

504
rmacs/buffer.rkt
View File

@ -1,504 +0,0 @@
#lang racket/base
(provide (struct-out buffer-mark-type)
make-buffergroup
initialize-buffergroup!
buffergroup-buffer-titles
buffer?
make-buffer
register-buffer!
lookup-buffer
unused-buffer-title
load-buffer
revert-buffer!
save-buffer!
buffer-rename!
buffer-reorder!
buffer-next
buffer-prev
buffer-title
buffer-dirty?
buffer-source
buffer-rope
buffer-group
buffer-locals
mark-buffer-clean!
buffer-editor
buffer-modeset
buffer-string-column-count
buffer-column
buffer-closest-pos-for-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-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
buffer-local
define-buffer-local
(except-out (struct-out command) command)
(struct-out exn:abort)
abort
copy-command
(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")
(require "file.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
[dirty? #:mutable] ;; Boolean
[source #:mutable] ;; (Option BufferSource)
[locals #:mutable] ;; (HashEqTable Symbol Any)
) #:prefab)
(struct exn:abort exn (detail duration) #:transparent)
(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 (buffergroup-buffer-titles g)
(map buffer-title (circular-list->list (buffergroup-members 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
#f
#f
(hasheq))))
(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)))
(define (load-buffer group src)
(define pieces (buffer-source-title-pieces src))
(define title (if (not group) (car pieces) (unused-buffer-title group pieces)))
(define b (make-buffer group title))
(set-buffer-source! b src)
(revert-buffer! b)
b)
(define (revert-buffer! buf)
(buffer-replace-contents! buf (string->rope (buffer-source-read (buffer-source buf))))
(mark-buffer-clean! buf))
(define (save-buffer! buf)
(buffer-source-write (buffer-source buf) (rope->string (buffer-rope buf)))
(mark-buffer-clean! buf))
(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 (mark-buffer-clean! buf)
(set-buffer-dirty?! buf #f))
(define (buffer-editor b)
(define g (buffer-group b))
(and g (buffergroup-editor g)))
(define (buffer-string-column-count buf start-column str)
(for/fold [(count 0)] [(ch str)]
(match ch
[#\tab (+ count (- 8 (modulo (+ start-column count) 8)))]
[#\newline (- start-column)]
[_ (+ count 1)])))
(define (buffer-column buf pos-or-mtype)
(define pos (->pos buf pos-or-mtype 'buffer-column))
(define str (rope->string (buffer-region buf (buffer-start-of-line buf pos) pos)))
(buffer-string-column-count buf 0 str))
(define (buffer-closest-pos-for-column buf sol-pos column-offset column)
(define g (rope-generator (subrope (buffer-rope buf) sol-pos)))
(let loop ((column-count column-offset) (pos sol-pos))
(cond
[(< column-count column)
(match (g)
[#\tab (loop (+ column-count (- 8 (modulo column-count 8))) (+ pos 1))]
[#\newline pos]
[(? char?) (loop (+ column-count 1) (+ pos 1))]
[_ pos])]
[(= column-count column) pos]
[(> column-count column) (- pos 1)])))
(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 (newline? ch) (equal? ch #\newline))
(define (buffer-start-of-line buf pm) (buffer-findf buf pm newline? #:forward? #f))
(define (buffer-end-of-line buf pm) (buffer-findf buf pm 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-pos buf pos-or-mtype)
(->pos buf pos-or-mtype 'buffer-pos))
(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 (and (buffer-mark-type? (mark-type-info mtype))
(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))
(when (buffer-source buf) (set-buffer-dirty?! buf #t))
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))
(when (buffer-source buf) (set-buffer-dirty?! buf #t))
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-local name [default #f])
(case-lambda
[(buf)
(hash-ref (buffer-locals buf) name (lambda () default))]
[(buf val)
(set-buffer-locals! buf (if (equal? val default)
(hash-remove (buffer-locals buf) name)
(hash-set (buffer-locals buf) name val)))
val]))
(define-syntax define-buffer-local
(syntax-rules ()
((_ name) (define name (buffer-local 'name)))
((_ name default) (define name (buffer-local 'name default)))))
(define (buffer-lift f buf . args)
(define new-rope (apply f (buffer-rope buf) args))
(set-buffer-rope! buf new-rope)
buf)
;;---------------------------------------------------------------------------
(define (abort #:detail [detail #f]
#:duration [duration #f]
fmt . args)
(raise (exn:abort (apply format fmt args)
(current-continuation-marks)
detail
duration)))
(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 (copy-command cmd
#:selector [selector (command-selector cmd)]
#:buffer [buffer (command-buffer cmd)]
#:window [window (command-window cmd)]
#:editor [editor (command-editor cmd)]
#:keyseq [keyseq (command-keyseq cmd)]
#:prefix-arg [prefix-arg (command-prefix-arg cmd)])
(struct-copy command cmd
[selector selector]
[buffer buffer]
[window window]
[editor editor]
[keyseq keyseq]
[prefix-arg prefix-arg]))
(define (invoke cmd)
(match-define (command selector buf _ _ keyseq _) cmd)
(define handler (modeset-lookup-command (buffer-modeset buf) selector))
(when (not handler)
(abort "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))])))

244
rmacs/circular-list.rkt
View File

@ -1,244 +0,0 @@
#lang racket/base
(provide circular-list?
circular-empty
circular-null?
circular-pair?
circular-cons
circular-snoc
circular-car
circular-cdr
circular-last
circular-butlast
circular-length
circular-list-rotate-forward
circular-list-rotate-backward
list->circular-list
circular-list->list
circular-list-map
circular-list-filter
circular-list-remove
circular-list-memf
circular-list-replacef)
(require racket/match)
(require (only-in racket/list splitf-at))
(struct circular-list ([front #:mutable]
[back #:mutable]
) #:prefab)
(define circular-empty (circular-list '() '()))
(define (circular-null? xs)
(equal? xs circular-empty))
(define (circular-pair? xs)
(and (circular-list? xs)
(not (circular-null? xs))))
(define (circular-uncons xs)
(cons (circular-car xs)
(circular-cdr xs)))
(define (circular-unsnoc xs)
(cons (circular-butlast xs)
(circular-last xs)))
(define (circular-cons* x xs)
(circular-list (cons x (circular-list-front xs)) (circular-list-back xs)))
(define (circular-snoc* xs x)
(circular-list (circular-list-front xs) (cons x (circular-list-back xs))))
(define-match-expander circular-cons
(syntax-rules () [(_ a d) (? circular-pair? (app circular-uncons (cons a d)))])
(syntax-rules () [(_ a d) (circular-cons* a d)]))
(define-match-expander circular-snoc
(syntax-rules () [(_ d a) (? circular-pair? (app circular-unsnoc (cons d a)))])
(syntax-rules () [(_ d a) (circular-snoc* d a)]))
(define (prime! xs)
(match xs
[(circular-list '() back)
(set-circular-list-front! xs (reverse back))
(set-circular-list-back! xs '())]
[_ (void)])
xs)
(define (anti-prime! xs)
(match xs
[(circular-list front '())
(set-circular-list-front! xs '())
(set-circular-list-back! xs (reverse front))]
[_ (void)])
xs)
(define (circular-car xs)
(if (circular-null? xs)
(error 'circular-car "Empty circular list")
(car (circular-list-front (prime! xs)))))
(define (circular-cdr xs)
(if (circular-null? xs)
(error 'circular-cdr "Empty circular list")
(begin (prime! xs)
(circular-list (cdr (circular-list-front xs)) (circular-list-back xs)))))
(define (circular-last xs)
(if (circular-null? xs)
(error 'circular-last "Empty circular list")
(car (circular-list-back (anti-prime! xs)))))
(define (circular-butlast xs)
(if (circular-null? xs)
(error 'circular-butlast "Empty circular list")
(begin (anti-prime! xs)
(circular-list (circular-list-front xs) (cdr (circular-list-back xs))))))
(define (circular-length xs)
(+ (length (circular-list-front xs))
(length (circular-list-back xs))))
(define (circular-list-rotate-forward xs)
(if (circular-null? xs)
xs
(begin (prime! xs)
(circular-list (cdr (circular-list-front xs))
(cons (car (circular-list-front xs))
(circular-list-back xs))))))
(define (circular-list-rotate-backward xs)
(if (circular-null? xs)
xs
(begin (anti-prime! xs)
(circular-list (cons (car (circular-list-back xs))
(circular-list-front xs))
(cdr (circular-list-back xs))))))
(define (list->circular-list xs)
(circular-list xs '()))
(define (circular-list->list xs)
(append (circular-list-front xs) (reverse (circular-list-back xs))))
(define (map/reversed-order f xs)
(if (null? xs)
'()
(let ((tail (map/reversed-order f (cdr xs))))
(cons (f (car xs)) tail))))
(define (circular-list-map f xs)
(circular-list (map f (circular-list-front xs))
(map/reversed-order f (circular-list-back xs))))
;; WARNING: does not preserve order of evaluation wrt back
(define (circular-list-filter f xs)
(circular-list (filter f (circular-list-front xs))
(filter f (circular-list-back xs))))
(define (circular-list-remove item xs [comparison equal?])
(define new-front (remove item (circular-list-front xs) comparison))
(if (= (length new-front) (length (circular-list-front xs)))
(circular-list (circular-list-front xs)
(reverse (remove item (reverse (circular-list-back xs)) comparison)))
(circular-list new-front (circular-list-back xs))))
(define (circular-list-memf f xs)
(let loop ((seen '()) (xs xs))
(if (circular-null? xs)
#f
(let ((a (circular-car xs)))
(if (f a)
(circular-list (circular-list-front xs)
(append seen (circular-list-back xs)))
(loop (cons a seen) (circular-cdr xs)))))))
(define (circular-list-replacef xs finder replacer)
(define (rejecter e) (not (finder e)))
(define-values (head tail) (splitf-at (circular-list-front xs) rejecter))
(if (null? tail)
(let-values (((head tail) (splitf-at (reverse (circular-list-back xs)) rejecter)))
(if (null? tail)
xs
(circular-list (circular-list-front xs)
(reverse (append head (replacer (car tail)) (cdr tail))))))
(circular-list (append head (replacer (car tail)) (cdr tail))
(circular-list-back xs))))
(module+ test
(require rackunit)
(define (check-abcdef abcdef)
(define bcdefa (circular-list-rotate-forward abcdef))
(check-equal? (circular-length abcdef) 6)
(check-equal? (circular-list->list abcdef) '(a b c d e f))
(check-equal? (circular-list->list bcdefa) '(b c d e f a))
(check-equal? (circular-list->list (for/fold [(xs abcdef)] [(i (circular-length abcdef))]
(circular-list-rotate-forward xs)))
(circular-list->list abcdef))
(check-equal? (circular-list->list (for/fold [(xs abcdef)] [(i (circular-length abcdef))]
(circular-list-rotate-backward xs)))
(circular-list->list abcdef)))
(check-abcdef (circular-list '(a b c) '(f e d)))
(check-abcdef (circular-list '(a b c d e f) '()))
(check-abcdef (circular-list '() '(f e d c b a)))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'e))
(lambda (x) (list 111))))
'(a b c d 111 f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'e))
(lambda (x) (list 111 222))))
'(a b c d 111 222 f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'b))
(lambda (x) (list 111))))
'(a 111 c d e f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'b))
(lambda (x) (list 111 222))))
'(a 111 222 c d e f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'x))
(lambda (x) (list 111 222))))
'(a b c d e f))
(check-equal? (match (circular-cons 1 circular-empty)
[(circular-cons a d) (cons a d)])
(cons 1 circular-empty))
(check-equal? (match (circular-list-rotate-forward (circular-cons 1 circular-empty))
[(circular-cons a d) (cons a d)])
(cons 1 circular-empty))
(check-equal? (match (circular-list-rotate-forward
(circular-cons 1 (circular-cons 2 circular-empty)))
[(circular-cons a d) (cons a (circular-list->list d))])
(list 2 1))
(check-equal? (match (circular-snoc circular-empty 1)
[(circular-snoc d a) (cons d a)])
(cons circular-empty 1))
(check-equal? (match (circular-list-rotate-forward (circular-snoc circular-empty 1))
[(circular-snoc d a) (cons d a)])
(cons circular-empty 1))
(check-equal? (match (circular-list-rotate-forward
(circular-snoc (circular-snoc circular-empty 2) 1))
[(circular-snoc d a) (cons a (circular-list->list d))])
(list 2 1))
(check-equal? (match (circular-snoc (circular-snoc circular-empty 1) 2)
[(circular-cons x (circular-cons y z)) (cons x (cons y (circular-list->list z)))])
(list 1 2))
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1 2 3) '(6 5 4))))
'(1 3 4 5 6))
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1) '(6 5 4 3 2))))
'(1 3 4 5 6))
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1 2 3 2) '(6 5 2 4))))
'(1 3 2 4 2 5 6))
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1) '(6 5 2 4 2 3 2))))
'(1 3 2 4 2 5 6)))

129
rmacs/diff.rkt
View File

@ -1,129 +0,0 @@
#lang racket/base
;; Text diff algorithm after Myers 1986 and Ukkonen 1985, following
;; Levente Uzonyi's Squeak Smalltalk implementation at
;; http://squeaksource.com/DiffMerge.html
;;
;; E. W. Myers, “An O(ND) difference algorithm and its variations,”
;; Algorithmica, vol. 1, no. 1–4, pp. 251–266, Nov. 1986.
;;
;; E. Ukkonen, “Algorithms for approximate string matching,” Inf.
;; Control, vol. 64, no. 1–3, pp. 100–118, Jan. 1985.
(provide diff-indices
apply-patch!)
(require racket/match)
(define (longest-common-subsequence* xs ys)
(define xs-length (vector-length xs))
(define ys-length (vector-length ys))
(define total-length (+ xs-length ys-length))
(define storage-length (+ 1 (* 2 total-length)))
(define frontier (make-vector storage-length 0))
(define candidates (make-vector storage-length '()))
(let/ec return
(for ((d (in-range 0 (+ total-length 1))))
(for ((k (in-range (- d) (+ d 1) 2)))
(define-values (index x)
(if (or (= k (- d))
(and (not (= k d))
(< (vector-ref frontier (+ total-length k -1))
(vector-ref frontier (+ total-length k 1)))))
(values (+ total-length k 1) (vector-ref frontier (+ total-length k 1)))
(values (+ total-length k -1) (+ (vector-ref frontier (+ total-length k -1)) 1))))
(let loop ((x x) (y (- x k)) (chain (vector-ref candidates index)))
(cond
[(and (< x xs-length) (< y ys-length) (equal? (vector-ref xs x) (vector-ref ys y)))
(loop (+ x 1) (+ y 1) (cons (cons x y) chain))]
[(and (>= x xs-length) (>= y ys-length))
(return (reverse chain))]
[else
(vector-set! frontier (+ total-length k) x)
(vector-set! candidates (+ total-length k) chain)]))))))
(define (sequence->vector xs) (for/vector ((x xs)) x))
(define (longest-common-subsequence xs ys)
(longest-common-subsequence* (sequence->vector xs) (sequence->vector ys)))
(define (diff-indices xs0 ys0)
(define xs (sequence->vector xs0))
(define ys (sequence->vector ys0))
(let loop ((i -1)
(j -1)
(matches (append (longest-common-subsequence* xs ys)
(list (cons (vector-length xs) (vector-length ys))))))
(match matches
['() '()]
[(cons (cons mi mj) rest)
(define li (- mi i 1))
(define lj (- mj j 1))
(if (or (positive? li) (positive? lj))
(cons (list (+ i 1) li (+ j 1) lj) (loop mi mj rest))
(loop mi mj rest))])))
;; patch-indices is a result from a call to diff-indices
(define (apply-patch! patch-indices ;; DiffIndices
remove-elements! ;; Nat Nat -> Void
insert-elements! ;; Nat Nat Nat -> Void
)
(for/fold [(skew 0)] [(patch patch-indices)]
(match-define (list old-i old-n new-i new-n) patch)
(define delta (- new-n old-n))
(if (negative? delta)
(begin (remove-elements! (+ old-i skew) (- delta))
(+ skew delta))
skew))
(for/fold [(skew 0)] [(patch patch-indices)]
(match-define (list old-i old-n new-i new-n) patch)
(define delta (- new-n old-n))
(insert-elements! (+ old-i skew) (max 0 delta) new-n)
(+ skew delta))
(void))
(module+ test
(require rackunit)
;; (define (test-example xs ys)
;; (printf "~v\n" (longest-common-subsequence xs ys))
;; (printf "~v\n" (diff-indices xs ys)))
;; (test-example "The red brown fox jumped over the rolling log"
;; "The brown spotted fox leaped over the rolling log")
(check-equal? (diff-indices "The red brown fox jumped over the rolling log"
"The brown spotted fox leaped over the rolling log")
'((4 4 4 0) (14 0 10 8) (18 3 22 3)))
(check-equal? (longest-common-subsequence "acbcaca" "bcbcacb")
'((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)))
(check-equal? (longest-common-subsequence "bcbcacb" "acbcaca")
'((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)))
(check-equal? (longest-common-subsequence "acba" "bcbb")
'((1 . 1) (2 . 2)))
(check-equal? (longest-common-subsequence "abcabba" "cbabac")
'((2 . 0) (3 . 2) (4 . 3) (6 . 4)))
(check-equal? (longest-common-subsequence "cbabac" "abcabba")
'((1 . 1) (2 . 3) (3 . 4) (4 . 6)))
(check-equal? (longest-common-subsequence
(vector (vector 1 1 1) (vector 1 1 1) (vector 1 1 1) (vector 1 1 1))
(vector (vector 1 1 1) (vector 2 2 2) (vector 1 1 1) (vector 4 4 4)))
'((0 . 0) (1 . 2)))
(check-equal? (diff-indices
(vector (vector 1 1 1) (vector 1 1 1) (vector 1 1 1) (vector 1 1 1))
(vector (vector 1 1 1) (vector 2 2 2) (vector 1 1 1) (vector 4 4 4)))
'((1 0 1 1) (2 2 3 1)))
(check-equal? (longest-common-subsequence '(a b c) '(d e f)) '())
(check-equal? (diff-indices '(a b c) '(d e f)) '((0 3 0 3)))
(let ((size 400))
(local-require profile)
(profile-thunk
(lambda ()
(diff-indices (make-vector size 'x)
(let ((v (make-vector size 'x)))
(vector-set! v 0 'a)
(vector-set! v 1 'b)
(vector-set! v 2 'c)
v))))))

386
rmacs/display.rkt
View File

@ -1,386 +0,0 @@
#lang racket/base
(provide (struct-out tty)
(struct-out pen)
stdin-tty
tty-rows
tty-columns
tty-last-row
tty-last-column
tty-cursor-row
tty-cursor-column
tty-display
tty-newline
tty-clear
tty-clear-to-eol
tty-reset
tty-goto
tty-set-pen!
tty-default-pen
tty-pen
tty-flush
tty-next-key
tty-next-key-evt
;; From ansi
(rename-out [ansi:color-black color-black]
[ansi:color-red color-red]
[ansi:color-green color-green]
[ansi:color-yellow color-yellow]
[ansi:color-blue color-blue]
[ansi:color-magenta color-magenta]
[ansi:color-cyan color-cyan]
[ansi:color-white color-white]))
(require racket/set)
(require racket/match)
(require (only-in racket/vector vector-copy))
(require (prefix-in ansi: ansi))
(require "diff.rkt")
(struct pen (foreground-color ;; Nat
background-color ;; Nat
bold? ;; Boolean
italic? ;; Boolean
) #:prefab)
(struct screen (rows ;; Nat
columns ;; Nat
[cursor-row #:mutable] ;; Nat
[cursor-column #:mutable] ;; Nat
[pen #:mutable] ;; Pen
contents ;; (Vector[rows] (Vector[columns] (Cons Pen Character)))
) #:prefab)
(struct tty (input ;; InputPort
output ;; OutputPort
key-reader ;; InputPort -> Key
[displayed-screen #:mutable] ;; Screen
[pending-screen #:mutable] ;; Screen
[utf-8-input? #:mutable] ;; Boolean
) #:prefab)
(define (make-screen rows columns pen)
(define contents (for/vector ((row rows)) (make-vector columns (cons pen 'empty))))
(screen rows columns 0 0 pen contents))
(define (copy-screen s)
(match-define (screen rows columns cursor-row cursor-column pen contents) s)
(define new-contents (for/vector ((row rows)) (vector-copy (vector-ref contents row))))
(screen rows columns cursor-row cursor-column pen new-contents))
(define tty-default-pen 'default)
(define *stdin-tty* #f)
(define (stdin-tty)
(when (not *stdin-tty*)
(ansi:tty-raw!)
(set! *stdin-tty*
(tty (current-input-port)
(current-output-port)
ansi:lex-lcd-input
(make-screen 24 80 tty-default-pen)
(make-screen 24 80 tty-default-pen)
(match (getenv "RMACS_UTF8_INPUT")
[(or #f "yes" "true" "1") #t]
[(or "no" "false" "0") #f]
[v (error 'RMACS_UTF8_INPUT
"Environment variable RMACS_UTF8_INPUT value ~v invalid: must be in ~v"
v
(list "yes" "true" "1" "no" "false" "0"))])))
(reset *stdin-tty*)
(plumber-add-flush! (current-plumber)
(lambda (h)
(output *stdin-tty*
(ansi:select-graphic-rendition ansi:style-normal)
(ansi:goto (tty-rows *stdin-tty*) 1))
(flush *stdin-tty*))))
*stdin-tty*)
;;---------------------------------------------------------------------------
;; Actually send changes to the display
(define (collect-position-report tty)
(let loop ()
(sync/timeout 0.5
(handle-evt (tty-input tty)
(lambda (p)
(match ((tty-key-reader tty) p)
[(? ansi:position-report? r) r]
[_ (loop)]))))))
(define (reset tty)
(output tty
(ansi:clear-screen)
(ansi:goto 999 999)
(ansi:position-report-request))
(flush tty)
(define report (or (collect-position-report tty)
(ansi:position-report 24 80))) ;; TODO: have a more flexible fallback
;; (set! report (ansi:position-report 5 10))
(define rows (ansi:position-report-row report))
(define columns (ansi:position-report-column report))
(set-pen tty tty-default-pen #:force #t)
(clear tty)
(flush tty)
(set-tty-displayed-screen! tty (make-screen rows columns tty-default-pen))
(set-tty-pending-screen! tty (make-screen rows columns tty-default-pen))
tty)
(define (set-pen tty p #:force [force #f])
(when (or force (not (equal? p (screen-pen (tty-displayed-screen tty)))))
(match p
[(pen fgcolor bgcolor bold? italic?)
(output tty
(apply ansi:select-graphic-rendition
`(,@(if bold? (list ansi:style-bold) (list))
,@(if italic? (list ansi:style-italic/inverse) (list))
,(ansi:style-text-color fgcolor)
,(ansi:style-background-color bgcolor))))]
['default
(output tty (ansi:select-graphic-rendition ansi:style-normal))])
(set-screen-pen! (tty-displayed-screen tty) p))
tty)
(define (clear tty)
(output tty (ansi:clear-screen/home))
(set-screen-cursor-row! (tty-displayed-screen tty) 0)
(set-screen-cursor-column! (tty-displayed-screen tty) 0)
tty)
(define (color-near-cursor s row-delta column-delta)
(define r (max 0 (min (- (screen-rows s) 1) (+ (screen-cursor-row s) row-delta))))
(define c (max 0 (min (- (screen-columns s) 1) (+ (screen-cursor-column s) column-delta))))
(car (vector-ref (vector-ref (screen-contents s) r) c)))
(define (vector-delete! v base count fill)
(vector-copy! v base v (+ base count) (vector-length v))
(for ((i (in-range (- (vector-length v) count) (vector-length v)))) (vector-set! v i fill)))
(define (vector-insert! v base count fill)
(vector-copy! v (+ base count) v base (- (vector-length v) count))
(for ((i (in-range base (+ base count)))) (vector-set! v i fill)))
(define (delete-lines tty n)
(define s (tty-displayed-screen tty))
(set-pen tty tty-default-pen)
(output tty (ansi:delete-lines n))
(define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
(vector-delete! (screen-contents s) (screen-cursor-row s) n blank-line)
tty)
(define (insert-lines tty n)
(define s (tty-displayed-screen tty))
(set-pen tty tty-default-pen)
(output tty (ansi:insert-lines n))
(define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
(vector-insert! (screen-contents s) (screen-cursor-row s) n blank-line)
tty)
(define (delete-columns tty n)
(define s (tty-displayed-screen tty))
(set-pen tty tty-default-pen)
(output tty (ansi:delete-characters n))
(define blank-cell (cons (screen-pen s) 'empty))
(define line (vector-ref (screen-contents s) (screen-cursor-row s)))
(vector-delete! line (screen-cursor-column s) n blank-cell)
tty)
(define (insert-columns tty n)
(define s (tty-displayed-screen tty))
(set-pen tty (color-near-cursor s 0 -1))
(output tty (ansi:insert-characters n))
(define blank-cell (cons (screen-pen s) 'empty))
(define line (vector-ref (screen-contents s) (screen-cursor-row s)))
(vector-insert! line (screen-cursor-column s) n blank-cell)
tty)
(define (output tty . items)
(for ((i items)) (display i (tty-output tty))))
(define (flush tty)
(flush-output (tty-output tty)))
;;---------------------------------------------------------------------------
;; Display to buffered screen
(define (tty-rows t) (screen-rows (tty-pending-screen t)))
(define (tty-columns t) (screen-columns (tty-pending-screen t)))
(define (tty-last-row t) (- (tty-rows t) 1))
(define (tty-last-column t) (- (tty-columns t) 1))
(define (tty-cursor-row t) (screen-cursor-row (tty-pending-screen t)))
(define (tty-cursor-column t) (screen-cursor-column (tty-pending-screen t)))
(define (non-empty? ch) (not (equal? ch 'empty)))
(define (putc tty ch)
(define s (tty-pending-screen tty))
(match ch
[#\return
(tty-goto tty (screen-cursor-row s) 0)]
[#\newline
(tty-goto tty (+ (screen-cursor-row s) 1) (screen-cursor-column s))]
[#\tab
(for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (putc tty #\space))]
[(and (? non-empty?) (? char-iso-control?))
(puts tty (format "[~x]" (char->integer ch)))]
[_
(when (< (screen-cursor-column s) (screen-columns s))
;; (tty-goto tty (+ (screen-cursor-row s) 1) 0)
(vector-set! (vector-ref (screen-contents s) (screen-cursor-row s))
(screen-cursor-column s)
(cons (screen-pen s) ch)))
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1))]))
(define (puts tty s)
(for ((ch s)) (putc tty ch)))
(define (tty-display tty . strings)
(for ((s strings)) (puts tty s)))
(define (tty-newline tty)
(tty-clear-to-eol tty)
(putc tty #\return)
(putc tty #\newline))
(define (tty-clear tty)
(set-tty-pending-screen! tty (make-screen (tty-rows tty) (tty-columns tty) (tty-pen tty)))
tty)
(define (tty-clear-to-eol tty)
(define start-column (tty-cursor-column tty))
(define pen (screen-pen (tty-pending-screen tty)))
(tty-set-pen! tty tty-default-pen)
(for ((i (max 0 (- (tty-columns tty) (tty-cursor-column tty))))) (putc tty 'empty))
(tty-set-pen! tty pen)
(tty-goto tty (tty-cursor-row tty) start-column)
tty)
(define (tty-reset tty)
(reset tty)
tty)
(define (tty-goto tty row0 column0)
(define row (max 0 (min (tty-last-row tty) row0)))
(define column (max 0 (min (tty-last-column tty) column0)))
(set-screen-cursor-row! (tty-pending-screen tty) row)
(set-screen-cursor-column! (tty-pending-screen tty) column)
tty)
(define (tty-set-pen! tty pen)
(set-screen-pen! (tty-pending-screen tty) pen)
tty)
(define (tty-pen tty)
(screen-pen (tty-pending-screen tty)))
;; (define (dump-screen s)
;; (list 'screen
;; (screen-rows s)
;; (screen-columns s)
;; (screen-cursor-row s)
;; (screen-cursor-column s)
;; (list->string
;; (for*/list ((line (screen-contents s))
;; (cell line)
;; #:when (non-empty? (cdr cell)))
;; (cdr cell)))))
(define (goto-if-needed s row column)
(cond
[(and (= (screen-cursor-row s) row) (= (screen-cursor-column s) column))
""]
[(= (screen-cursor-row s) row)
(begin0 (ansi:goto-column (+ column 1))
(set-screen-cursor-column! s column))]
[else
(begin0 (ansi:goto (+ row 1) (+ column 1))
(set-screen-cursor-row! s row)
(set-screen-cursor-column! s column))]))
(define (advance-cursor! tty s)
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1))
(when (= (screen-cursor-column s) (screen-columns s))
(when (< (screen-cursor-row s) (- (screen-rows s) 1))
(output tty "\r\n"))
(set-screen-cursor-column! s 0)
(set-screen-cursor-row! s (+ (screen-cursor-row s) 1))))
;; Answers #t when an edit to a line would produce a visible effect.
(define (interesting-change? old-line new-line column right-margin)
(for/or [(i (in-range column right-margin))]
(not (equal? (vector-ref old-line i) (vector-ref new-line i)))))
(define (repair-span! tty old new-line row first-col cell-count)
(define trailing-empty-count
(for/fold [(empty-count 0)] [(column (in-range first-col (+ first-col cell-count)))]
(match-define (cons new-pen new-ch) (vector-ref new-line column))
(if (non-empty? new-ch)
(begin (set-pen tty new-pen)
(output tty (goto-if-needed old row column) new-ch)
(advance-cursor! tty old)
0)
(+ empty-count 1))))
(when (and (positive? trailing-empty-count) (= (+ first-col cell-count) (tty-columns tty)))
(output tty (ansi:clear-to-eol))))
(define (repair-line! tty old new row)
(define columns (screen-columns new))
(define old-line (vector-ref (screen-contents old) row))
(define new-line (vector-ref (screen-contents new) row))
(define patches (diff-indices old-line new-line))
(if (<= (length patches) 3)
(apply-patch! patches
(lambda (first-col cols-to-remove)
(when (interesting-change? old-line new-line first-col columns)
(output tty (goto-if-needed old row first-col))
(delete-columns tty cols-to-remove)))
(lambda (first-col cols-to-insert cell-count)
(when (interesting-change? old-line new-line first-col columns)
(output tty (goto-if-needed old row first-col))
(when (and (positive? cols-to-insert)
(interesting-change? old-line
new-line
(+ first-col cols-to-insert)
columns))
(insert-columns tty cols-to-insert))
(repair-span! tty old new-line row first-col cell-count))))
(repair-span! tty old new-line row 0 columns)))
(define (tty-flush tty)
(define old (tty-displayed-screen tty))
(define new (tty-pending-screen tty))
(apply-patch! (diff-indices (screen-contents old) (screen-contents new))
(lambda (first-row lines-to-remove)
(output tty (goto-if-needed old first-row (screen-cursor-column old)))
(delete-lines tty lines-to-remove))
(lambda (first-row lines-to-insert line-count)
(when (positive? lines-to-insert)
(output tty (goto-if-needed old first-row (screen-cursor-column old)))
(insert-lines tty lines-to-insert))
(for ((row (in-range first-row (+ first-row line-count))))
(repair-line! tty old new row))))
(output tty (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new)))
(flush tty)
(set-tty-displayed-screen! tty (struct-copy screen new [pen (screen-pen old)]))
(set-tty-pending-screen! tty (copy-screen new))
tty)
;;---------------------------------------------------------------------------
;; Input
(define (tty-next-key tty)
(define k (ansi:lex-lcd-input (tty-input tty) #:utf-8? (tty-utf-8-input? tty)))
(if (equal? k (ansi:key #\[ (set 'control))) ;; ESC
(or (sync/timeout 0.5
(handle-evt (tty-next-key-evt tty)
(lambda (k) (ansi:add-modifier 'meta k))))
k)
k))
(define (tty-next-key-evt tty)
(handle-evt (tty-input tty)
(lambda (_) (tty-next-key tty))))

407
rmacs/editor.rkt
View File

@ -1,407 +0,0 @@
#lang racket/base
(provide (except-out (struct-out editor) editor)
make-editor
configure-fresh-buffer!
find-buffer
window-layout
window-width
window-height
open-window
close-other-windows
close-window
resize-window
select-window
windows-for-buffer
window-for-buffer
visit-file!
render-editor!
editor-next-window
editor-prev-window
editor-command
invoke/history
editor-last-command?
editor-active-buffer
editor-active-modeset
editor-mainloop
editor-request-shutdown!
editor-force-redisplay!
clear-message
message
start-recursive-edit
abandon-recursive-edit)
(require racket/match)
(require "buffer.rkt")
(require "display.rkt")
(require "window.rkt")
(require "render.rkt")
(require "mode.rkt")
(require "keys.rkt")
(require "rope.rkt")
(require "circular-list.rkt")
(require "file.rkt")
(struct editor (buffers ;; BufferGroup
[tty #:mutable] ;; Tty
[windows #:mutable] ;; (CircularList (List Window SizeSpec)), abstract window layout
[active-window #:mutable] ;; (Option Window)
[running? #:mutable] ;; Boolean
[default-modeset #:mutable] ;; ModeSet
[layout #:mutable] ;; (Option (List Layout))
[last-command #:mutable] ;; (Option Command)
echo-area ;; Buffer
mini-window ;; Window
[message-expiry-time #:mutable] ;; (Option Number)
[recursive-edit #:mutable] ;; (Option Buffer)
) #:prefab)
(define (make-editor #:tty [tty (stdin-tty)]
#:default-modeset [default-modeset (make-modeset)])
(define g (make-buffergroup))
(define scratch (make-buffer g "*scratch*"
#:initial-contents ";; This is the scratch buffer.\n\n"))
(define echo-area (make-buffer #f "*echo-area*"))
(define w (make-window scratch))
(define ws (list->circular-list (list (list w (relative-size 1)))))
(define miniwin (make-window echo-area))
(define e (editor g tty ws w #f default-modeset #f #f echo-area miniwin #f #f))
(initialize-buffergroup! g e)
(configure-fresh-buffer! e scratch)
(window-move-to! w (buffer-size scratch))
(set-window-status-line?! miniwin #f)
e)
(define (configure-fresh-buffer! editor buffer)
(buffer-apply-modeset! buffer (editor-default-modeset editor))
buffer)
(define (find-buffer editor [title0 #f] #:initial-contents [initial-contents ""])
(define g (editor-buffers editor))
(define title (or title0 (unused-buffer-title g '())))
(or (lookup-buffer g title)
(configure-fresh-buffer! editor (make-buffer g title #:initial-contents initial-contents))))
(define (split-size s)
(match s
[(absolute-size _) (relative-size 1)] ;; can't scale fixed-size windows
[(relative-size w) (relative-size (/ w 2))]))
(define (merge-sizes surviving disappearing)
(match* (surviving disappearing)
[((relative-size a) (relative-size b)) (relative-size (+ a b))]
[(_ _) surviving]))
(define (windows-for-buffer editor buffer)
(map car (filter (lambda (e) (eq? (window-buffer (car e)) buffer))
(circular-list->list (editor-windows editor)))))
(define (window-for-buffer editor buffer)
(define ws (windows-for-buffer editor buffer))
(and (pair? ws) (car ws)))
(define (entry-for? window) (lambda (e) (eq? (car e) window)))
(define (invalidate-layout! editor)
(set-editor-layout! editor #f))
(define (layout! editor)
(when (not (editor-layout editor))
(set-editor-layout! editor (layout-windows (circular-list->list (editor-windows editor))
(editor-mini-window editor)
(tty-columns (editor-tty editor))
(tty-rows (editor-tty editor)))))
(editor-layout editor))
(define (window-layout editor win)
(cond [(memf (lambda (l) (eq? (layout-window l) win)) (layout! editor)) => car]
[else #f]))
(define ((-layout-accessor- getter) editor window)
(cond [(window-layout editor window) => getter]
[else #f]))
(define window-size-spec (-layout-accessor- layout-size-spec))
(define window-width (-layout-accessor- layout-width))
(define window-height (-layout-accessor- layout-height))
(define (update-window-entry editor win updater)
(set-editor-windows! editor (circular-list-replacef (editor-windows editor)
(entry-for? win)
updater))
(invalidate-layout! editor))
(define (open-window editor buffer
#:after-window [after-window (editor-active-window editor)]
#:proportional? [proportional? #f]
#:activate? [activate? #t])
(define existing-w (window-for-buffer editor buffer))
(define existing-size (window-size-spec editor after-window))
(define new-size (if proportional? existing-size (split-size existing-size)))
(define new-point (or (and existing-w (buffer-mark-pos* buffer (window-point existing-w))) 0))
(define new-window (make-window buffer #:point new-point))
(update-window-entry editor after-window
(lambda (e) (list (list after-window new-size)
(list new-window new-size))))
(when activate? (set-editor-active-window! editor new-window))
new-window)
(define (close-other-windows editor win)
(for ((entry (circular-list->list (editor-windows editor))) #:when (not (eq? (car entry) win)))
(set-window-buffer! (car entry) #f))
(set-editor-windows! editor (list->circular-list (list (list win (relative-size 1)))))
(set-editor-active-window! editor win)
(invalidate-layout! editor))
(define (close-window editor win)
(define prev (editor-prev-window editor win))
(define prev-size (window-size-spec editor prev))
(define win-size (window-size-spec editor win))
(when (and prev (> (circular-length (editor-windows editor)) 1))
(when (eq? (editor-active-window editor) win) (set-editor-active-window! editor prev))
(update-window-entry editor win (lambda (e) '()))
(resize-window editor prev (merge-sizes prev-size win-size))))
(define (resize-window editor win size)
(update-window-entry editor win (lambda (e) (list (list win size)))))
(define (select-window editor win)
(when (window-layout editor win)
(set-editor-active-window! editor win)))
(define (visit-file! editor filename)
(set-window-buffer! (editor-active-window editor)
(configure-fresh-buffer! editor
(load-buffer (editor-buffers editor)
(local-file-buffer-source filename)))))
(define (render-editor! editor)
(render-windows! (editor-tty editor)
(layout! editor)
(editor-active-window editor)))
(define (editor-active-buffer editor)
(define w (editor-active-window editor))
(and w (window-buffer w)))
(define (editor-active-modeset editor)
(let* ((b (editor-active-buffer editor))
(b (if (eq? b (editor-echo-area editor)) (editor-recursive-edit editor) b)))
(and b (buffer-modeset b))))
(define (editor-next-window editor win)
(cond [(circular-list-memf (entry-for? win)
(editor-windows editor)) => (compose car
circular-car
circular-list-rotate-forward)]
[else #f]))
(define (editor-prev-window editor win)
(cond [(circular-list-memf (entry-for? win)
(editor-windows editor)) => (compose car
circular-car
circular-list-rotate-backward)]
[else #f]))
(define (editor-command selector editor
#:keyseq [keyseq #f]
#:prefix-arg [prefix-arg '#:default])
(window-command selector (editor-active-window editor)
#:editor editor
#:keyseq keyseq
#:prefix-arg prefix-arg))
(define (invoke/history cmd)
(define editor (command-editor cmd))
(with-handlers* ([exn:abort? (lambda (e)
(message editor "~a" (exn-message e)
#:duration (exn:abort-duration e))
(void))])
(define result (invoke cmd))
(set-editor-last-command! editor cmd)
result))
(define (editor-last-command? editor . possible-selectors)
(and (editor-last-command editor)
(for/or ((selector (in-list possible-selectors)))
(eq? (command-selector (editor-last-command editor)) selector))))
(define (root-keyseq-handler editor)
(modeset-keyseq-handler (editor-active-modeset editor)))
(define *error-count* 0)
(define (open-debugger editor exc)
(local-require (only-in web-server/private/util exn->string))
(define error-report (exn->string exc))
(log-error "Exception:\n~a\n" error-report)
(set! *error-count* (+ *error-count* 1))
(when (>= *error-count* 3) (exit))
(define b (find-buffer editor "*Error*"))
(buffer-replace-contents! b (string->rope error-report))
(open-window editor b))
(define (editor-mainloop editor)
(when (editor-running? editor) (error 'editor-mainloop "Nested mainloop"))
(set-editor-running?! editor #t)
(with-handlers* ([exn? (lambda (exc)
(set-editor-running?! editor #f)
(open-debugger editor exc)
(editor-mainloop editor))])
(let loop ((total-keyseq '())
(input '())
(handler (root-keyseq-handler editor))
(next-repaint-deadline 0))
(define (request-repaint) (or next-repaint-deadline (+ (current-inexact-milliseconds) 20)))
(define (wait-for-input next-handler)
(when (editor-running? editor)
(sync (if next-repaint-deadline
(handle-evt (alarm-evt next-repaint-deadline)
(lambda (_)
(loop total-keyseq '() next-handler next-repaint-deadline)))
never-evt)
(let ((expiry-time (editor-message-expiry-time editor)))
(if expiry-time
(handle-evt (alarm-evt expiry-time)
(lambda (_)
(clear-message editor)
(loop total-keyseq '() next-handler 0)))
never-evt))
(handle-evt (tty-next-key-evt (editor-tty editor))
(lambda (new-key)
(define new-input (list new-key))
(clear-message editor)
(loop (append total-keyseq new-input)
new-input
next-handler
next-repaint-deadline))))))
(cond
[(and next-repaint-deadline (>= (current-inexact-milliseconds) next-repaint-deadline))
(render-editor! editor)
(loop total-keyseq input handler #f)]
[(null? input)
(wait-for-input handler)]
[else
(match (handler editor input)
[(unbound-key-sequence)
(when (not (invoke/history (editor-command 'unbound-key-sequence editor
#:keyseq total-keyseq)))
(message editor "Unbound key sequence: ~a" (keyseq->keyspec total-keyseq)))
(loop '() '() (root-keyseq-handler editor) (request-repaint))]
[(incomplete-key-sequence next-handler)
(message #:log? #f editor "~a-" (keyseq->keyspec total-keyseq))
(wait-for-input next-handler)]
[(command-invocation selector prefix-arg remaining-input)
(define accepted-input
(let remove-tail ((keyseq total-keyseq))
(if (equal? keyseq remaining-input)
'()
(cons (car keyseq) (remove-tail (cdr keyseq))))))
(invoke/history (editor-command selector editor
#:keyseq accepted-input
#:prefix-arg prefix-arg))
(loop '() remaining-input (root-keyseq-handler editor) (request-repaint))])]))))
(define (editor-request-shutdown! editor)
(set-editor-running?! editor #f))
(define (editor-force-redisplay! editor)
(tty-reset (editor-tty editor))
(invalidate-layout! editor))
(define (clear-message editor)
(when (positive? (buffer-size (editor-echo-area editor)))
(buffer-replace-contents! (editor-echo-area editor) (empty-rope))
(define re (editor-recursive-edit editor))
(when (and re (not (eq? (window-buffer (editor-mini-window editor)) re)))
(set-window-buffer! (editor-mini-window editor) re (buffer-size re)))
(set-editor-message-expiry-time! editor #f)
(invalidate-layout! editor)))
(define (message #:duration [duration0 #f]
#:log? [log? #t]
editor fmt . args)
(define duration (or duration0 (and (editor-recursive-edit editor) 2)))
(define msg (string->rope (apply format fmt args)))
(define echo-area (editor-echo-area editor))
(when log?
(let* ((msgbuf (find-buffer editor "*Messages*"))
(msgwins (filter (lambda (w) (equal? (buffer-mark-pos msgbuf (window-point w))
(buffer-size msgbuf)))
(windows-for-buffer editor msgbuf))))
(buffer-insert! msgbuf (buffer-size msgbuf) (rope-append msg (string->rope "\n")))
(for ((w msgwins)) (buffer-mark! msgbuf (window-point w) (buffer-size msgbuf)))))
(buffer-replace-contents! echo-area msg)
(set-window-buffer! (editor-mini-window editor) echo-area (buffer-size echo-area))
(invalidate-layout! editor)
(when duration
(set-editor-message-expiry-time! editor (+ (current-inexact-milliseconds) (* duration 1000.0))))
(render-editor! editor))
(define (start-recursive-edit editor buf)
(when (editor-recursive-edit editor)
(abort "Command attempted to use minibuffer while in minibuffer"))
(set-editor-recursive-edit! editor buf)
(define miniwin (editor-mini-window editor))
(set-window-buffer! miniwin buf (buffer-size buf))
(set-editor-windows! editor
(circular-snoc (editor-windows editor)
(list miniwin (absolute-size 0))))
(set-editor-active-window! editor miniwin)
(invalidate-layout! editor))
(define (abandon-recursive-edit editor)
(set-editor-recursive-edit! editor #f)
(define echo-area (editor-echo-area editor))
(define miniwin (editor-mini-window editor))
(set-window-buffer! miniwin echo-area (buffer-size echo-area))
(when (eq? (editor-active-window editor) miniwin)
(set-editor-active-window! editor (car (circular-car (editor-windows editor)))))
(update-window-entry editor miniwin (lambda (e) '()))
(invalidate-layout! editor))
;;---------------------------------------------------------------------------
(define-command kernel-mode (save-buffers-kill-terminal buf #:editor ed)
#:bind-key "C-x C-c"
(editor-request-shutdown! ed))
(define-command kernel-mode (force-redisplay buf #:editor ed)
#:bind-key "C-l"
(editor-force-redisplay! ed))
(define-command kernel-mode (keyboard-quit buf)
#:bind-key "C-g"
(abort "Quit"))
(define-command kernel-mode (dump-buffer-to-stderr buf #:window win #:editor ed)
#:bind-key "C-M-x"
(local-require racket/pretty)
(log-info "")
(log-info "--------------------------------------------------------------------------------")
(log-info "--------------------------------------------------------------------------------")
(log-info "========================================================================= WINDOW")
(log-info "id ~v" (window-id win))
(log-info "top ~v ~v" (window-top win) (buffer-mark-pos* buf (window-top win)))
(log-info "point ~v ~v" (window-point win) (buffer-mark-pos* buf (window-point win)))
(log-info "mark ~v ~v" (window-mark win) (buffer-mark-pos* buf (window-mark win)))
(log-info "title ~v" (buffer-title buf))
(log-info "rope:")
(pretty-write (buffer-rope buf) (current-error-port))
(log-info "modeset:")
(pretty-write (buffer-modeset buf) (current-error-port))
(let ((t (editor-tty ed)))
(log-info "terminal width ~v height ~v cursor-row ~v -col ~v"
(tty-columns t) (tty-rows t) (tty-cursor-row t) (tty-cursor-column t)))
(log-info "editor layout:")
(cond [(editor-layout ed) =>
(lambda (layouts)
(for ((l layouts))
(match-define (layout w s tt ll ww hh) l)
(log-info " - ~a ~v top ~a left ~a width ~a height ~a"
(window-id w) s tt ll ww hh)))]
[else (log-info " - not cached")])
(log-info "editor size-specs: ~v"
(for/list ((e (circular-list->list (editor-windows ed))))
(list (window-id (car e)) (cadr e))))
(log-info "--------------------------------------------------------------------------------"))

37
rmacs/file.rkt
View File

@ -1,37 +0,0 @@
#lang racket/base
(provide gen:buffer-source
buffer-source-title-pieces
buffer-source-mtime
buffer-source-read
buffer-source-write
(struct-out local-file-buffer-source)
local-file-buffer-source-path)
(require racket/generic)
(require (only-in racket/file file->string))
(require (only-in racket/path normalize-path))
(define-generics buffer-source
(buffer-source-title-pieces buffer-source)
(buffer-source-mtime buffer-source)
(buffer-source-read buffer-source)
(buffer-source-write buffer-source content))
(struct local-file-buffer-source (filename)
#:transparent
#:methods gen:buffer-source
[(define (buffer-source-title-pieces src)
(reverse (map path->string (explode-path (local-file-buffer-source-path src)))))
(define (buffer-source-mtime src)
(file-or-directory-modify-seconds (local-file-buffer-source-path src)))
(define (buffer-source-read src)
(file->string (local-file-buffer-source-path src)))
(define (buffer-source-write src content)
(call-with-output-file (local-file-buffer-source-path src)
(lambda (p) (write-string content p))
#:exists 'replace))])
(define (local-file-buffer-source-path src)
(normalize-path (simplify-path (local-file-buffer-source-filename src))))

11
rmacs/info.rkt
View File

@ -1,11 +0,0 @@
#lang setup/infotab
(define name "editor")
(define blurb
(list
`(p "Emacs-like editor.")))
(define homepage "https://github.com/tonyg/racket-ansi")
(define primary-file "main.rkt")
(define racket-launcher-names '("rmacs"))
(define racket-launcher-libraries '("main.rkt"))

235
rmacs/keys.rkt
View File

@ -1,235 +0,0 @@
#lang racket/base
;; Keyspecs, keyseqs and keymaps
(provide parse-key-sequence
keyspec->keyseq
key->keyspec
keyseq->keyspec
(struct-out keymap)
empty-keymap
keymap-update
keymap-bind
keymap-unbind
keymap-lookup
;; From ansi/lcd-terminal
(struct-out key)
(struct-out unknown-escape-sequence)
add-modifier)
(require racket/set)
(require racket/match)
(require (only-in racket/list append-map))
(require (only-in racket/string
string-join
string-split
string-trim))
(require ansi/lcd-terminal)
;;---------------------------------------------------------------------------
;; Key sequence parsing
(define (read-string-to-end s)
(define p (open-input-string s))
(define result (read p))
(and (eof-object? (peek-char p))
result))
(define (bad-key lexeme fmt . args)
(error 'parse-key-sequence "~a in key ~v" (apply format fmt args) (string-trim lexeme)))
(define (parse-modifiers modifiers lexeme)
(for/set ((mod (string-split (string-upcase modifiers) "-")))
(match mod
["C" 'control]
["S" 'shift]
["M" 'meta]
[_ (bad-key lexeme "Unknown modifier ~a" mod)])))
(define (parse-key-sequence s)
(match s
[(pregexp "^ *#:default(( +.*)|$)" (list lexeme rest _))
(cons '#:default (parse-key-sequence rest))]
[(pregexp "^ *(([cCsSmM]-)*)\"([^\"]*)\"(.*)" (list lexeme modifiers _ stringspec rest))
(define mods (parse-modifiers modifiers lexeme))
(define seq (unknown-escape-sequence (or (read-string-to-end (format "#\"~a\"" stringspec))
(bad-key lexeme "Bad raw input sequence"))))
(cons (key seq mods) (parse-key-sequence rest))]
[(pregexp "^ *(([cCsSmM]-)*)<([^>]+)>(( +.*)|$)" (list lexeme modifiers _ symname rest _))
(define mods (parse-modifiers modifiers lexeme))
(cons (key (string->symbol symname) mods)
(parse-key-sequence rest))]
[(pregexp "^ *(([cCsSmM]-)*)(?i:esc)(( +.*)|$)" (list lexeme modifiers _ rest _))
(define mods (parse-modifiers modifiers lexeme))
(cons (key #\[ (set-add mods 'control)) (parse-key-sequence rest))]
[(pregexp "^ *(([cCsSmM]-)*)([^ ]+)(( +.*)|$)" (list lexeme modifiers _ keystr rest _))
(define mods (parse-modifiers modifiers lexeme))
(define keychar (or (read-string-to-end (format "#\\~a" keystr))
(bad-key lexeme "Bad single-character key")))
(cons (key (if (set-member? mods 'control)
(char-upcase keychar)
keychar)
mods)
(parse-key-sequence rest))]
[(pregexp "^ *$")
'()]
[_ (bad-key s "Unexpected junk")]))
(define (keyspec->keyseq what original-keyspec)
(let convert ((keyspec original-keyspec))
(cond
[(key? keyspec) (list keyspec)]
[(keyword? keyspec) (list keyspec)]
[(string? keyspec) (parse-key-sequence keyspec)]
[(list? keyspec) (append-map convert keyspec)]
[else (error what "Invalid key specification: ~v" original-keyspec)])))
(define (format-modifiers mods suffix)
(if (set-empty? mods)
suffix
(string-append (string-join (map (lambda (m)
(match m
['control "C"]
['shift "S"]
['meta "M"]))
(set->list mods))
"-")
"-"
suffix)))
(define (key->keyspec k)
(match k
[(? keyword?) (format "~a" k)]
[(key value modifiers)
(define-values (str updated-modifiers)
(match value
[(unknown-escape-sequence bs)
(define s (format "~v" bs))
(values (substring s 1 (string-length s)) modifiers)]
[(? symbol? s)
(values (format "<~a>" s) modifiers)]
[#\[ #:when (set-member? modifiers 'control)
(values "ESC" (set-remove modifiers 'control))]
[(? char? c)
(define s (format "~v" c))
(define maybe-downcase (if (set-member? modifiers 'control) string-downcase values))
(values (maybe-downcase (substring s 2 (string-length s))) modifiers)]))
(format-modifiers updated-modifiers str)]))
(define (keyseq->keyspec keyseq)
(and keyseq (string-join (map key->keyspec keyseq) " ")))
;;---------------------------------------------------------------------------
;; Keymaps
(struct keymap (table
) #:prefab)
(define (empty-keymap)
(keymap (hash)))
(define (keymap-update km keyspec updater)
(define original-keyseq (keyspec->keyseq 'keymap-bind keyspec))
(let loop ((prefix-rev '())
(keyseq original-keyseq)
(km km))
(match keyseq
['() (updater (reverse prefix-rev) km original-keyseq)]
[(cons k rest)
(cond
[(keymap? km)
(let* ((new (loop (cons k prefix-rev) rest (hash-ref (keymap-table km) k #f)))
(newtab (if new
(hash-set (keymap-table km) k new)
(hash-remove (keymap-table km) k))))
(if (hash-empty? newtab)
#f
(struct-copy keymap km [table newtab])))]
[(not km)
(loop prefix-rev keyseq (empty-keymap))]
[else
(error 'keymap-update
"Cannot update keyspec ~v, as a shorter prefix ~v exists"
(keyseq->keyspec original-keyseq)
(keyseq->keyspec (reverse prefix-rev)))])])))
(define (keymap-bind km keyspec command)
(keymap-update km keyspec (lambda (prefix oldval newseq)
(if oldval
(error 'keymap-bind "Cannot bind ~v, as prefix ~v exists"
(keyseq->keyspec newseq)
(keyseq->keyspec prefix))
command))))
(define (keymap-bind* km specs-and-commands)
(match specs-and-commands
['() km]
[(cons (list keyspec command) rest) (keymap-bind* (keymap-bind km keyspec command) rest)]))
(define (keymap-unbind km keyspec)
(or (keymap-update km keyspec (lambda (prefix oldval newseq) #f))
(empty-keymap)))
(define (keymap-lookup km keyspec)
(define original-keyseq (keyspec->keyseq 'keymap-lookup keyspec))
(let loop ((keyseq original-keyseq)
(km km))
(match keyseq
['() (values km keyseq)]
[(cons k rest)
(match km
[(keymap table) (loop rest (or (hash-ref table k #f)
(hash-ref table '#:default #f)))]
[_ (values km keyseq)])])))
;;---------------------------------------------------------------------------
(module+ test
(require rackunit racket/pretty)
(check-equal? (parse-key-sequence "<") (list (key #\< (set))))
(check-equal? (parse-key-sequence ">") (list (key #\> (set))))
(check-equal? (parse-key-sequence "#:default #:default")
(list '#:default '#:default))
(check-equal? (parse-key-sequence "esc ESC")
(list (key #\[ (set 'control))
(key #\[ (set 'control))))
(define km (keymap-bind* (empty-keymap) (list (list "C-x o" 'other-window)
(list "C-x 2" 'split-window)
(list "C-x 1" 'delete-other-windows)
(list "C-x 0" 'delete-window))))
(check-equal? km
(keymap (hash (key #\X (set 'control))
(keymap (hash (key #\o (set)) 'other-window
(key #\2 (set)) 'split-window
(key #\1 (set)) 'delete-other-windows
(key #\0 (set)) 'delete-window)))))
(set! km (keymap-unbind km "C-x 1"))
(check-equal? km
(keymap (hash (key #\X (set 'control))
(keymap (hash (key #\o (set)) 'other-window
(key #\2 (set)) 'split-window
(key #\0 (set)) 'delete-window)))))
(check-equal? (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0")
(keymap (hash (key #\X (set 'control))
(keymap (hash (key #\o (set)) 'other-window)))))
(check-equal? (keymap-unbind (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0") "C-x o")
(empty-keymap))
(check-equal? (keymap-unbind km "C-x")
(empty-keymap))
(define (lookup s)
(define-values (result remaining-input) (keymap-lookup km s))
(list result remaining-input))
(check-equal? (lookup "C-x") (list (keymap (hash (key #\o (set)) 'other-window
(key #\2 (set)) 'split-window
(key #\0 (set)) 'delete-window))
'()))
(check-equal? (lookup "C-x 1") (list #f '()))
(check-equal? (lookup "C-x 2") (list 'split-window '()))
(check-equal? (lookup "C-c") (list #f '()))
(check-equal? (lookup "C-c C-c") (list #f (list (key #\C (set 'control)))))
)

20
rmacs/lists.rkt
View File

@ -1,20 +0,0 @@
#lang racket/base
;; List utilities :-(
(provide replacef)
(require racket/list)
(define (replacef lst finder replacer)
(define-values (head tail) (splitf-at lst (lambda (e) (not (finder e)))))
(if (null? tail)
head
(append head
(replacer (car tail))
(cdr tail))))
(module+ test
(require rackunit)
(check-equal? (replacef '(1 2 3 4 5) even? (lambda (n) (list n n n)))
'(1 2 2 2 3 4 5)))

36
rmacs/main.rkt
View File

@ -1,36 +0,0 @@
#lang racket/base
(provide rmacs)
(require racket/match)
(require "editor.rkt")
(require "buffer.rkt")
(require "mode.rkt")
(require "mode/fundamental.rkt")
(define (rmacs #:initial-files [initial-files '()])
(define e (make-editor #:default-modeset (modeset-add-mode kernel-modeset
fundamental-mode)))
(for ((file initial-files)) (visit-file! e file))
(editor-mainloop e))
(module+ main
(require racket/trace)
(current-trace-notify (lambda (s) (log-info "TRACE: ~a" s)))
(void
(rmacs #:initial-files (match (current-command-line-arguments)
['#()
(list
(build-path (collection-file-path "main.rkt" "rmacs")
'up 'up "doc" "xterm_controls.txt"))]
[(vector files ...)
files])))
;; (require profile)
;; (require ansi)
;; (void (profile-thunk (lambda () (begin0 (main)
;; (tty-restore!)
;; (display (select-graphic-rendition style-normal))
;; (display (clear-screen))
;; (flush-output)))))
)

151
rmacs/minibuf.rkt
View File

@ -1,151 +0,0 @@
#lang racket/base
(provide read-from-minibuffer
recursive-edit-field-start
recursive-edit-mode
recursive-edit-accept-hook
recursive-edit-cancel-hook
completing-read
simple-completion
completing-read-mode
completing-read-string=?-hook
completing-read-completion-hook
completing-read-acceptable-hook)
(require "buffer.rkt")
(require "editor.rkt")
(require "mode.rkt")
(require "keys.rkt")
(require "rope.rkt")
(require "window.rkt")
(require "strings.rkt")
;;---------------------------------------------------------------------------
(define (read-from-minibuffer editor
prompt
#:initial [initial ""]
#:on-accept k-accept
#:on-cancel [k-cancel void])
(define buf (make-buffer #f "*minibuf*"))
(configure-fresh-buffer! editor buf)
(buffer-add-mode! buf recursive-edit-mode)
(buffer-replace-contents! buf (string->rope prompt))
(buffer-mark! buf recursive-edit-field-start (buffer-size buf))
(buffer-insert! buf (buffer-size buf) (string->rope initial))
(recursive-edit-selected-window buf (editor-active-window editor))
(recursive-edit-accept-hook buf k-accept)
(recursive-edit-cancel-hook buf k-cancel)
(start-recursive-edit editor buf)
buf)
(define recursive-edit-field-start (mark-type (buffer-mark-type 'recursive-edit-field-start
'*minibuf*
#t)
'left))
(define recursive-edit-mode (make-mode "recursive-edit"))
(define-buffer-local recursive-edit-selected-window)
(define-buffer-local recursive-edit-accept-hook (lambda (content) (void)))
(define-buffer-local recursive-edit-cancel-hook (lambda () (void)))
(define-command recursive-edit-mode (abort-recursive-edit buf #:editor ed)
#:bind-key "C-g"
(abandon-recursive-edit ed)
(select-window ed (recursive-edit-selected-window buf))
((recursive-edit-cancel-hook buf)))
(define (recursive-edit-contents buf)
(rope->string (buffer-region buf recursive-edit-field-start (buffer-size buf))))
(define-command recursive-edit-mode (exit-minibuffer buf #:editor ed)
#:bind-key "C-m"
#:bind-key "C-j"
(abandon-recursive-edit ed)
(select-window ed (recursive-edit-selected-window buf))
((recursive-edit-accept-hook buf) (recursive-edit-contents buf)))
(define-command recursive-edit-mode (minibuf-beginning-of-line buf #:window win)
#:bind-key "C-a"
#:bind-key "<home>"
(define limit (buffer-mark-pos* buf recursive-edit-field-start))
(if (and limit (> (buffer-mark-pos buf (window-point win)) limit))
(window-move-to! win limit)
(buffer-move-mark-to-start-of-line! buf (window-point win))))
;;---------------------------------------------------------------------------
(define (completing-read editor
prompt
completion-fn
#:string=? [string=? string=?]
#:initial [initial ""]
#:acceptable? [acceptable? (lambda (v) #t)]
#:on-accept k-accept
#:on-cancel [k-cancel void])
(define buf (read-from-minibuffer editor prompt
#:initial initial
#:on-accept k-accept
#:on-cancel k-cancel))
(buffer-add-mode! buf completing-read-mode)
(completing-read-string=?-hook buf string=?)
(completing-read-completion-hook buf completion-fn)
(completing-read-acceptable-hook buf acceptable?)
buf)
(define (simple-completion collection)
(define collection-strings (for/list ((c collection)) (format "~a" c)))
(lambda (prefix string=?)
(for/list ((c collection-strings) #:when (string-prefix? prefix c string=?)) c)))
(define completing-read-mode (make-mode "completing"))
(define-buffer-local completing-read-string=?-hook
string=?)
(define-buffer-local completing-read-completion-hook
(lambda (v) (abort "completing-read-completion-hook not set")))
(define-buffer-local completing-read-acceptable-hook
(lambda (v) #t))
(define (common-string-prefix strs string=?)
(if (null? (cdr strs))
(car strs)
(let ((len (let loop ((i 1))
(if (for/and ((c (cdr strs)))
(and (>= (string-length c) i)
(string=? (substring (car strs) 0 i) (substring c 0 i))))
(loop (+ i 1))
(- i 1)))))
(substring (car strs) 0 len))))
(define-command completing-read-mode (minibuffer-complete buf #:editor ed)
#:bind-key "C-i"
#:bind-key "tab"
(define string=? (completing-read-string=?-hook buf))
(define prefix (recursive-edit-contents buf))
(define unfiltered-completions ((completing-read-completion-hook buf) prefix string=?))
(define completions (filter (lambda (s) (string-prefix? prefix s string=?))
unfiltered-completions))
(if (pair? completions)
(let ((common-prefix (common-string-prefix completions string=?))
(complete? (null? (cdr completions))))
(if (string=? common-prefix prefix)
;; No progress.
(if complete?
(message ed "Sole completion")
(message ed "Completions: ~a" completions))
;; Some progress
(buffer-region-update! buf
recursive-edit-field-start
(buffer-size buf)
(lambda (_old)
(string->rope common-prefix)))))
(message ed "No match")))
(define-command completing-read-mode (exit-minibuffer buf
#:next-method next-method
#:command cmd
#:editor ed)
(when ((completing-read-acceptable-hook buf) (recursive-edit-contents buf))
(next-method cmd)))

215
rmacs/mode.rkt
View File

@ -1,215 +0,0 @@
#lang racket/base
;; Modes and modesets.
(provide (struct-out mode)
(struct-out modeset)
(struct-out incomplete-key-sequence)
(struct-out unbound-key-sequence)
(struct-out command-invocation)
make-raw-mode
make-mode
mode-add-constraints
mode-keymap-bind!
mode-keymap-unbind!
mode-keymap-rebind!
mode-define-command!
mode-undefine-command!
mode-redefine-command!
mode-command-selectors
make-modeset
modeset-add-mode
modeset-remove-mode
modeset-toggle-mode
modeset-keyseq-handler
modeset-lookup-command
modeset-command-selectors
kernel-mode
kernel-modeset)
(require racket/set)
(require racket/match)
(require (only-in racket/list filter-map))
(require "keys.rkt")
(require "topsort.rkt")
(struct mode (id
name
[keymap #:mutable]
[commands #:mutable]
dispatch-keys-before
dispatch-keys-after
interpret-commands-before
interpret-commands-after
) #:prefab)
(struct modeset (modes
key-dispatch-order
command-interpretation-order
) #:prefab)
(struct incomplete-key-sequence (handler) #:prefab)
(struct unbound-key-sequence () #:prefab)
(struct command-invocation (selector prefix-arg remaining-input) #:prefab)
(define (make-raw-mode name)
(mode (gensym name)
name
(empty-keymap)
(hasheq)
(seteq)
(seteq)
(seteq)
(seteq)))
(define (mode-add-constraints m
#:dispatch-keys-before [kb '()]
#:dispatch-keys-after [ka '()]
#:interpret-commands-before [cb '()]
#:interpret-commands-after [ca '()])
(define (convert modes) (list->seteq (for/list ((m modes))
(if (keyword? m)
m
(mode-id m)))))
(struct-copy mode m
[dispatch-keys-before
(set-union (mode-dispatch-keys-before m) (convert kb))]
[dispatch-keys-after
(set-union (mode-dispatch-keys-after m) (convert ka))]
[interpret-commands-before
(set-union (mode-interpret-commands-before m) (convert cb))]
[interpret-commands-after
(set-union (mode-interpret-commands-after m) (convert ca))]))
(define (make-mode name)
(mode-add-constraints (make-raw-mode name)
#:dispatch-keys-before '(#:kernel)
#:interpret-commands-before '(#:kernel)))
(define (mode-keymap-bind! m keyspec command)
(set-mode-keymap! m (keymap-bind (mode-keymap m) keyspec command))
m)
(define (mode-keymap-unbind! m keyspec)
(set-mode-keymap! m (keymap-unbind (mode-keymap m) keyspec))
m)
(define (mode-keymap-rebind! m keyspec command)
(mode-keymap-bind! (mode-keymap-unbind! m keyspec) keyspec command))
(define (mode-define-command! m selector handler)
(when (hash-has-key? (mode-commands m) selector)
(error 'mode-define-command!
"Duplicate command handler for ~a in mode ~a"
selector
(mode-id m)))
(set-mode-commands! m (hash-set (mode-commands m) selector handler))
m)
(define (mode-undefine-command! m selector)
(set-mode-commands! m (hash-remove (mode-commands m) selector))
m)
(define (mode-redefine-command! m selector handler)
(mode-define-command! (mode-undefine-command! m selector) selector handler))
(define (mode-command-selectors m)
(list->seteq (hash-keys (mode-commands m))))
(define (make-modeset)
(modeset (hasheq)
'()
'()))
(define (modeset-add-mode ms m)
(compute-modeset-orders
(struct-copy modeset ms [modes (hash-set (modeset-modes ms)
(mode-id m)
m)])))
(define (modeset-remove-mode ms m)
(compute-modeset-orders
(struct-copy modeset ms [modes (hash-remove (modeset-modes ms) (mode-id m))])))
(define (modeset-toggle-mode ms m)
((if (hash-has-key? (modeset-modes ms) (mode-id m)) modeset-remove-mode modeset-add-mode)
ms
m))
(define (edges ms before-getter after-getter)
(for/fold [(es '())]
[(m (in-hash-values (modeset-modes ms)))]
(define mid (mode-id m))
(append (for/list [(nid (before-getter m))] (list mid nid))
(for/list [(nid (after-getter m))] (list nid mid))
es)))
(define (compute-modeset-order ms what before-getter after-getter)
(or (topsort (edges ms before-getter after-getter) #:comparison eq?)
(error 'compute-modeset-orders "Inconsistent ~a order: ~v"
(hash-keys (modeset-modes ms)))))
(define (compute-modeset-orders ms)
(struct-copy modeset ms
[key-dispatch-order (compute-modeset-order ms
"key dispatch"
mode-dispatch-keys-before
mode-dispatch-keys-after)]
[command-interpretation-order (compute-modeset-order ms
"command interpretation"
mode-interpret-commands-before
mode-interpret-commands-after)]))
(define (order->modes ms order-getter)
(define modes (modeset-modes ms))
(filter-map (lambda (id) (hash-ref modes id #f)) (order-getter ms)))
(define (modeset-keyseq-handler ms)
(let handler-for-maps ((maps (map mode-keymap (order->modes ms modeset-key-dispatch-order))))
(lambda (e ks)
(define results (map (lambda (km)
(define-values (result remaining-input) (keymap-lookup km ks))
(list result remaining-input)) maps))
(let process-results ((results results))
(match results
['() (unbound-key-sequence)]
[(cons (list result remaining-input) rest)
(cond
[(not result) (process-results rest)]
[(keymap? result) (incomplete-key-sequence
(handler-for-maps (filter keymap? (map car results))))]
[(procedure? result)
(if (null? remaining-input)
(incomplete-key-sequence result)
(result e remaining-input))]
[else (command-invocation result '#:default remaining-input)])])))))
(define (modeset-lookup-command ms selector)
(let search ((tables (map mode-commands
(order->modes ms modeset-command-interpretation-order))))
(match tables
['() #f]
[(cons table rest)
(define handler (hash-ref table selector #f))
(if handler
(lambda (cmd)
(handler cmd
(lambda ([cmd cmd])
(define next-method (search rest))
(when next-method (next-method cmd)))))
(search rest))])))
(define (modeset-command-selectors ms)
(for/fold [(selectors (seteq))] [(m (hash-values (modeset-modes ms)))]
(set-union selectors (mode-command-selectors m))))
(define kernel-mode
(mode-add-constraints (make-raw-mode "kernel")
#:dispatch-keys-after '(#:kernel)
#:interpret-commands-after '(#:kernel)))
(define kernel-modeset
(modeset-add-mode (make-modeset) kernel-mode))

190
rmacs/mode/fundamental.rkt
View File

@ -1,190 +0,0 @@
#lang racket/base
(provide fundamental-mode)
(require racket/set)
(require racket/match)
(require racket/string)
(require "../api.rkt")
(define fundamental-mode (make-mode "fundamental"))
(define-command fundamental-mode (self-insert-command buf #:window win #:keyseq keyseq)
(match keyseq
[(list (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift))
(buffer-insert! buf (window-point win) (string->rope (string ch)))]
[_ #f]))
(define-command fundamental-mode (unbound-key-sequence buf #:command cmd #:keyseq keyseq)
(invoke (copy-command cmd #:selector 'self-insert-command)))
(define-command fundamental-mode (quoted-insert buf #:window win #:keyseq keyseq)
#:bind-key "C-q #:default"
(match keyseq
[(list _ (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift))
(buffer-insert! buf (window-point win) (string->rope (string ch)))]
[(list _ (key (? char? ch0) modifiers)) #:when (equal? modifiers (set 'control))
(define ch (integer->char (- (char->integer (char-upcase ch0)) (char->integer #\A) -1)))
(buffer-insert! buf (window-point win) (string->rope (string ch)))]
[_ #f]))
(define-command fundamental-mode (newline buf #:window win)
#:bind-key "C-m"
#:bind-key "C-j"
(buffer-insert! buf (window-point win) (string->rope "\n")))
(define (move-forward-n-lines win count)
(define buf (window-buffer win))
(for ((i count))
(buffer-move-mark-to-end-of-line! buf (window-point win))
(buffer-move-mark! buf (window-point win) 1)))
(define (move-backward-n-lines win count)
(define buf (window-buffer win))
(for ((i count))
(buffer-move-mark-to-start-of-line! buf (window-point win))
(buffer-move-mark! buf (window-point win) -1)))
(define (move-to-column win col)
(define buf (window-buffer win))
(define sol (buffer-start-of-line buf (window-point win)))
(buffer-mark! buf (window-point win) (buffer-closest-pos-for-column buf sol 0 col)))
(define-command fundamental-mode (forward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "C-f"
#:bind-key "<right>"
(buffer-move-mark! buf (window-point win) count))
(define-command fundamental-mode (backward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "C-b"
#:bind-key "<left>"
(buffer-move-mark! buf (window-point win) (- count)))
(define-buffer-local last-vertical-movement-preferred-column)
(define (vertical-movement-preferred-column editor win)
(define buf (window-buffer win))
(last-vertical-movement-preferred-column
buf
(or (and (editor-last-command? editor
'next-line
'prev-line)
(last-vertical-movement-preferred-column buf))
(buffer-column buf (window-point win)))))
(define-command fundamental-mode (next-line buf #:window win #:editor ed #:prefix-arg [count 1])
#:bind-key "C-n"
#:bind-key "<down>"
(define col (vertical-movement-preferred-column ed win))
(move-forward-n-lines win count)
(move-to-column win col))
(define-command fundamental-mode (prev-line buf #:window win #:editor ed #:prefix-arg [count 1])
#:bind-key "C-p"
#:bind-key "<up>"
(define col (vertical-movement-preferred-column ed win))
(move-backward-n-lines win count)
(move-to-column win col))
(define-command fundamental-mode (move-end-of-line buf #:window win #:prefix-arg [count 1])
#:bind-key "C-e"
#:bind-key "<end>"
(when (positive? count) (move-forward-n-lines win (- count 1)))
(buffer-move-mark-to-end-of-line! buf (window-point win)))
(define-command fundamental-mode (move-beginning-of-line buf #:window win #:prefix-arg [count 1])
#:bind-key "C-a"
#:bind-key "<home>"
(when (positive? count) (move-forward-n-lines win (- count 1)))
(buffer-move-mark-to-start-of-line! buf (window-point win)))
(define-command fundamental-mode (delete-backward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "<backspace>"
#:bind-key "C-h" ;; differs from GNU emacs
(define pos (buffer-mark-pos buf (window-point win)))
(buffer-region-update! buf (- pos 1) pos (lambda (_deleted) (empty-rope))))
(define-command fundamental-mode (delete-forward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "<delete>"
#:bind-key "C-d"
(define pos (buffer-mark-pos buf (window-point win)))
(buffer-region-update! buf pos (+ pos 1) (lambda (_deleted) (empty-rope))))
(define (set-window-mark! win [pos (window-point win)])
(window-mark! win pos)
(message (window-editor win) "Mark set")
pos)
(define-command fundamental-mode (beginning-of-buffer buf #:window win #:prefix-arg [tenths 0])
#:bind-key "M-<"
#:bind-key "C-<home>"
#:bind-key "<begin>"
(if (eq? tenths '#:prefix) (set! tenths 0) (set-window-mark! win))
(window-move-to! win (* (buffer-size buf) (max 0 (min 10 tenths)) 1/10)))
(define-command fundamental-mode (end-of-buffer buf #:window win #:prefix-arg [tenths 0])
#:bind-key "M->"
#:bind-key "C-<end>"
(if (eq? tenths '#:prefix) (set! tenths 0) (set-window-mark! win))
(window-move-to! win (* (buffer-size buf) (- 10 (max 0 (min 10 tenths))) 1/10)))
(define-command fundamental-mode (exchange-point-and-mark buf #:window win)
#:bind-key "C-x C-x"
(define m (buffer-mark-pos* buf (window-mark win)))
(when m
(window-mark! win)
(window-move-to! win m)))
(define-command fundamental-mode (set-mark-command buf #:window win #:prefix-arg arg)
#:bind-key "C-@"
#:bind-key "C-space"
(if (eq? arg '#:prefix)
(let ((m (buffer-mark-pos* buf (window-mark win))))
(and m (window-move-to! win m)))
(set-window-mark! win)))
(define-command fundamental-mode (split-window-below buf #:window win #:editor ed)
#:bind-key "C-x 2"
(open-window ed buf #:after-window win #:activate? #f))
(define-command fundamental-mode (delete-other-windows buf #:window win #:editor ed)
#:bind-key "C-x 1"
(close-other-windows ed win))
(define-command fundamental-mode (delete-window buf #:window win #:editor ed)
#:bind-key "C-x 0"
(close-window ed win))
(define-command fundamental-mode (other-window buf #:window win #:editor ed)
#:bind-key "C-tab"
#:bind-key "C-x o"
(select-window ed (editor-next-window ed win)))
(define-command fundamental-mode (save-buffer buf)
#:bind-key "C-x C-s"
(save-buffer! buf))
(define-command fundamental-mode (execute-extended-command buf #:command cmd #:editor ed)
#:bind-key "M-x"
(completing-read ed "M-x "
(simple-completion (modeset-command-selectors (buffer-modeset buf)))
#:on-accept (lambda (content)
(define selector (string->symbol content))
(invoke (copy-command cmd
#:selector (string->symbol content)
#:keyseq #f)))))
(define-command fundamental-mode (switch-to-buffer buf #:window win #:editor ed)
#:bind-key "C-x b"
(define default-target (buffer-next buf))
(completing-read ed
(format "Switch to buffer~a: "
(if default-target
(format " (default ~a)" (buffer-title default-target))
""))
(simple-completion (buffergroup-buffer-titles (editor-buffers ed)))
#:on-accept (lambda (title0)
(define title1 (string-trim title0))
(define title (if (equal? title1 "") #f title1))
(define target (if title (find-buffer ed title) default-target))
(set-window-buffer! win target))))

186
rmacs/render.rkt
View File

@ -1,186 +0,0 @@
#lang racket/base
(provide (struct-out absolute-size)
(struct-out relative-size)
(struct-out layout)
layout-windows
render-windows!)
(require racket/match)
(require "buffer.rkt")
(require "window.rkt")
(require "display.rkt")
(require "rope.rkt")
(require "wrap.rkt")
;; A SizeSpec is either
;; -- (absolute-size PositiveInteger), a specific size in screen rows
;; -- (relative-size PositiveReal), a weighted window size
(struct absolute-size (lines) #:prefab)
(struct relative-size (weight) #:prefab)
;; A Layout is a (layout Window SizeSpec Nat Nat)
(struct layout (window ;; Window
size-spec ;; SizeSpec
top ;; Nat, a row
left ;; Nat, a column
width ;; Nat
height ;; Nat
) #:prefab)
(define (newline? c) (equal? c #\newline))
;; Finseth's book defines a C routine, Framer(), which is intended to
;; ensure that the `top_of_window` mark, denoting the position where
;; display should begin for the current window, is in a sane position.
;; The mark is left alone unless the cursor is outside the currently
;; displayed window, either above or below. If the mark needs to be
;; moved, it is moved to a line such that the cursor, after redisplay,
;; will end up at a configurable percentage of the way down the
;; window.
;;
;; It is here that we perform soft-wrapping of lines.
;;
;; Window Nat -> (List (Pair Nat Nat))
;; Ensures that window-top is sanely positioned with respect to
;; window-point. Returns wrapped line spans starting at the new
;; window-top.
(define (frame! win available-line-count window-width
#:preferred-position-fraction [preferred-position-fraction 1/2])
(define buf (window-buffer win))
(define old-top-of-window-pos (or (buffer-mark-pos* buf (window-top win)) 0))
(define preferred-distance-from-bottom
(ceiling (* available-line-count (- 1 preferred-position-fraction))))
(define g (buffer-lines-reverse/wrap buf (window-point win) basic-wrap window-width))
(define spans
(let loop ((line-count 0)
(all-spans '())
(preferred-spans '()))
(define-values (pos eol-pos) (g))
(define span (cons pos eol-pos))
(define new-all-spans (cons span all-spans))
(define new-preferred-spans (if (= line-count preferred-distance-from-bottom)
new-all-spans
preferred-spans))
(cond
[(not pos) all-spans] ;; we hit buffer top before our preferred distance. NB all-spans
[(= pos old-top-of-window-pos) new-all-spans]
[(>= line-count (- available-line-count 1)) new-preferred-spans]
[else (loop (+ line-count 1) new-all-spans new-preferred-spans)])))
(buffer-mark! buf (window-top win) (caar spans))
spans)
(define (tty-body-style t is-active?)
(tty-set-pen! t tty-default-pen))
(define (tty-statusline-style t is-active?)
(tty-set-pen! t (pen color-black color-white #f #f)))
(define (render-window! t win window-top window-width window-height is-active?)
(define buf (window-buffer win))
(define available-line-count (if (window-status-line? win) (- window-height 1) window-height))
(define spans (frame! win available-line-count window-width))
(define cursor-pos (buffer-mark-pos buf (window-point win)))
(tty-goto t window-top 0)
(tty-body-style t is-active?)
(define (render-span sol-pos eol-pos line-count cursor-coordinates)
(define line (rope->string (buffer-region buf sol-pos eol-pos)))
(tty-display t line)
(tty-newline t)
(if (<= sol-pos cursor-pos eol-pos)
(list (+ line-count window-top)
(let ((line-to-cursor (substring line 0 (- cursor-pos sol-pos))))
(buffer-string-column-count buf 0 line-to-cursor)))
cursor-coordinates))
(define (render-top-spans spans line-count cursor-coordinates)
(cond
[(>= line-count available-line-count) cursor-coordinates]
[(null? spans)
(define g (buffer-lines-forward/wrap buf (window-point win) basic-wrap window-width))
(g) ;; discard first span, since it has already been covered
(render-bottom-spans g line-count cursor-coordinates)]
[else
(render-top-spans (cdr spans)
(+ line-count 1)
(render-span (caar spans) (cdar spans) line-count cursor-coordinates))]))
(define (render-bottom-spans g line-count cursor-coordinates)
(if (>= line-count available-line-count)
cursor-coordinates
(let-values (((sol-pos eol-pos) (g)))
(if sol-pos
(render-bottom-spans g
(+ line-count 1)
(render-span sol-pos eol-pos line-count cursor-coordinates))
(begin (for ((i (- available-line-count line-count))) (tty-newline t))
cursor-coordinates)))))
(define cursor-coordinates (render-top-spans spans 0 #f))
(when (window-status-line? win)
(tty-statusline-style t is-active?)
(let* ((prefix (format "-:~a- ~a " (if (buffer-dirty? buf) "**" "--") (buffer-title buf)))
(remaining-length (- (tty-columns t) (string-length prefix))))
(tty-display t prefix)
(when (positive? remaining-length) (tty-display t (make-string remaining-length #\-)))))
cursor-coordinates)
(define (layout-windows ws miniwin total-width total-height [minimum-height 4])
(define miniwin-spans
(frame! miniwin (min 4 total-height) total-width #:preferred-position-fraction 1))
(define miniwin-height (length miniwin-spans))
(define total-weight (foldl + 0 (map (lambda (e)
(match (cadr e)
[(absolute-size _) 0]
[(relative-size w) w])) ws)))
(define reserved-lines (foldl + miniwin-height (map (lambda (e)
(match (cadr e)
[(absolute-size lines) lines]
[(relative-size _) 0])) ws)))
(define proportional-lines (- total-height reserved-lines))
(define ws-without-miniwin ;; miniwin is in ws when minibuffer active; otherwise, not
(filter (lambda (e) (not (eq? (car e) miniwin))) ws))
(append (let loop ((ws ws-without-miniwin) (offset 0) (remaining proportional-lines))
(match ws
['() '()]
[(cons (list (== miniwin eq?) _) rest)
(loop rest offset remaining)]
[(cons (list w (and spec (absolute-size lines))) rest)
(cons (layout w spec offset 0 total-width lines)
(loop rest (+ offset lines) remaining))]
[(cons (list w (and spec (relative-size weight))) rest)
(define height (max minimum-height
(inexact->exact
(round (* proportional-lines (/ weight total-weight))))))
(if (>= remaining height)
(if (null? rest)
(list (layout w spec offset 0 total-width remaining))
(cons (layout w spec offset 0 total-width height)
(loop rest (+ offset height) (- remaining height))))
(if (>= remaining minimum-height)
(list (layout w spec offset 0 total-width remaining))
'()))]))
(list (layout miniwin
(absolute-size miniwin-height)
(- total-height miniwin-height)
0
total-width
miniwin-height))))
(define (render-windows! t layouts active-window)
(tty-body-style t #f)
(tty-goto t 0 0)
(define active-cursor-position
(for/fold [(cursor-position #f)] [(e layouts)]
(match-define (layout w _spec window-top _left window-width window-height) e)
(define is-active? (eq? w active-window))
(define window-cursor-position
(render-window! t w window-top window-width window-height is-active?))
(if is-active? window-cursor-position cursor-position)))
(when active-cursor-position
(tty-goto t (car active-cursor-position) (cadr active-cursor-position)))
(tty-flush t))

587
rmacs/rope.rkt
View File

@ -1,587 +0,0 @@
#lang racket/base
;; Ropes for text editing
(provide empty-strand
string->strand
strand->string
substrand
strand-equal?
strand-empty?
(rename-out [rope?* rope?])
rope-empty?
empty-rope
strand->rope
string->rope
rope->string
rope-size
rope-marks
rope-split
rope-append
rope-concat
subrope
rope-generator
rope-seek
(struct-out mark-type)
has-mark?
find-mark
find-mark-pos
find-all-marks/type
set-mark
clear-mark
replace-mark
clear-all-marks)
(require racket/set)
(require racket/match)
(require racket/generator)
(module+ test (require rackunit racket/pretty))
;; A Stickiness is one of
;; -- '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 Any Stickiness). MarkTypes can be
;; associated with a set of Any values at each position in the rope.
(struct mark-type (info stickiness) #:prefab)
;; A Strand is a (strand String Number Number), representing a
;; substring of a string.
(struct strand (text offset count) #:prefab)
;; A Rope is a splay tree representing a long piece of text.
;; #f is the empty Rope; otherwise a (rope) struct instance.
;; INVARIANT: Adjacent ropes will be merged to maximize sharing.
(struct rope (strand ;; Strand
left ;; Rope or #f
right ;; Rope or #f
size* ;; Number, total length of this rope
marks* ;; (Seteq MarkType)
mark-index ;; (Hasheq MarkType (Hash Number (Set Any))), marks in this span
) #:prefab)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Strands
(define *glom-up-to* 128)
(define (empty-strand) (strand "" 0 0))
(define (string->strand s)
(strand s 0 (string-length s)))
(define (strand->string t)
(match-define (strand text offset count) t)
(if (and (zero? offset) (= count (string-length text)))
text
(substring text offset (+ offset count))))
(define (compute-range-index index default limit)
(cond [(not index) default]
[(zero? limit) 0]
[else (max 0 (min limit (if (negative? index) (+ index limit) index)))]))
(define (substrand t0 [lo0 #f] [hi0 #f])
(define t (if (string? t0) (string->strand t0) t0))
(define lo (compute-range-index lo0 0 (strand-count t)))
(define hi (compute-range-index hi0 (strand-count t) (strand-count t)))
(strand (strand-text t)
(+ (strand-offset t) lo)
(- hi lo)))
(define (strand-maybe-append t1 t2)
(match-define (strand text1 offset1 count1) t1)
(match-define (strand text2 offset2 count2) t2)
(or (and (zero? count1) t2)
(and (zero? count2) t1)
(and (eq? text1 text2)
(= (+ offset1 count1) offset2)
(strand text1 offset1 (+ count1 count2)))
;; TODO: measure to see if the following improves or worsens memory usage
(and (< (+ count1 count2) *glom-up-to*)
(string->strand (string-append (strand->string t1) (strand->string t2))))))
(define (strand-equal? t1 t2)
(string=? (strand->string t1)
(strand->string t2)))
(define (strand-empty? t)
(zero? (strand-count t)))
(module+ test
(check-equal? (strand-count (empty-strand)) 0)
(check-equal? (strand-count (string->strand "")) 0)
(check-true (strand-equal? (empty-strand) (string->strand ""))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ropes
(define (empty-rope) #f)
(define (rope-empty? r)
(equal? r (empty-rope)))
(define (rope?* r)
(or (rope-empty? r)
(rope? r)))
(define (strand->rope t)
(rope t (empty-rope) (empty-rope) (strand-count t) (seteq) (hasheq)))
(define (string->rope s)
(strand->rope (string->strand s)))
(define (rope->string r)
(define buf (make-string (rope-size r)))
(let fill! ((r r) (offset 0))
(when r
(fill! (rope-left r) offset)
(define lo (rope-lo r))
(define s (rope-strand r))
(string-copy! buf
(+ offset lo)
(strand-text s)
(strand-offset s)
(+ (strand-offset s) (strand-count s)))
(fill! (rope-right r) (+ offset lo (strand-count s)))))
buf)
(define (replace-left r n) (if r (reindex (struct-copy rope r [left n])) n))
(define (replace-right r n) (if r (reindex (struct-copy rope r [right n])) n))
(define (replace-both r rl rr) (reindex (struct-copy rope r [left rl] [right rr])))
(define (splay-to r direction-finder arg0)
;; zig: last. desired position is a direct (left/right) child of r.
;; zig-zig: desired position is within a (left-left/right-right) grandchild of r.
;; zig-zag: desired position is within a (left-right/right-left) grandchild of r.
(define-values (where arg1) (direction-finder arg0 r))
(match where
['here (values arg1 r)]
['left
(define rl (rope-left r))
(define-values (where arg2) (direction-finder arg1 rl))
(match where
['here ;; zig.
(values arg2 (replace-right rl (replace-left r (and rl (rope-right rl)))))]
['left ;; zig-zig
(define-values (v rll) (splay-to (rope-left rl) direction-finder arg2))
(values v (replace-right rll (replace-both rl
(and rll (rope-right rll))
(replace-left r (rope-right rl)))))]
['right ;; zig-zag
(define-values (v rlr) (splay-to (rope-right rl) direction-finder arg2))
(values v (replace-both rlr
(replace-right rl (rope-left rlr))
(replace-left r (rope-right rlr))))])]
['right
(define rr (rope-right r))
(define-values (where arg2) (direction-finder arg1 rr))
(match where
['here ;; zig.
(values arg2 (replace-left rr (replace-right r (and rr (rope-left rr)))))]
['left ;; zig-zag
(define-values (v rrl) (splay-to (rope-left rr) direction-finder arg2))
(values v (replace-both rrl
(replace-right r (rope-left rrl))
(replace-left rr (rope-right rrl))))]
['right ;; zig-zig
(define-values (v rrr) (splay-to (rope-right rr) direction-finder arg2))
(values v (replace-left rrr (replace-both rr
(replace-right r (rope-left rr))
(and rrr (rope-left rrr)))))])]))
(define (rope-lo r)
(rope-size (rope-left r)))
(define (rope-lo+hi r)
(define lo (rope-lo r))
(values lo (+ lo (strand-count (rope-strand r)))))
(define (find-position pos r)
(if (rope-empty? r)
(values 'here (zero? pos))
(let-values (((lo hi) (rope-lo+hi r)))
(cond
[(< pos lo) (values 'left pos)]
[(< pos hi) (values 'here #t)]
[else (values 'right (- pos hi))]))))
;; (define (dump-mark-tree r)
;; (define (-> r)
;; (if r
;; (list (set->list (rope-marks* r))
;; (hash->list (rope-mark-index r))
;; (-> (rope-left r))
;; (-> (rope-right r)))
;; '()))
;; (local-require racket/pretty)
;; (pretty-print (-> r) (current-error-port)))
;; Searches from pos (inclusive) in the direction indicated.
;; Pos points to a mark-position, not a character-position.
(define (find-mark* r forward? mtype start-pos)
(define (search-here r offset start-pos)
(define marks (hash-ref (rope-mark-index r) mtype #f))
(define lo (rope-lo r))
(if (not marks)
#f
(let ((pos-comparer (if forward? < >))
(boundary-comparer (if forward? >= <=)))
(for/fold [(candidate #f)] [((pos value) (in-hash marks))]
(if (and (or (not candidate)
(pos-comparer pos (car candidate)))
(boundary-comparer pos start-pos))
(cons (+ pos offset lo) value)
candidate)))))
(define (search r offset start-pos)
(and r
(set-member? (rope-marks r) mtype)
(let-values (((lo hi) (rope-lo+hi r)))
(if forward?
(or (and (< start-pos lo) (search (rope-left r) offset start-pos))
(and (<= start-pos hi) (search-here r offset (- start-pos lo)))
(search (rope-right r) (+ offset hi) (- start-pos hi)))
(or (and (> start-pos hi) (search (rope-right r) (+ offset hi) (- start-pos hi)))
(and (>= start-pos lo) (search-here r offset (- start-pos lo)))
(search (rope-left r) offset start-pos)))
)))
(search r 0 start-pos))
(define (has-mark? r mtype)
(and r (set-member? (rope-marks r) mtype)))
(define (find-mark r mtype
#:forward? [forward? #t]
#:position [start-pos (if forward? 0 (rope-size r))])
(find-mark* r forward? mtype start-pos))
(define (find-mark-pos r mtype
#:forward? [forward? #t]
#:position [start-pos (if forward? 0 (rope-size r))])
(cond [(find-mark* r forward? mtype start-pos) => car]
[else #f]))
(define (mark-union h1 h2 offset)
(for/fold [(h h1)] [((pos val) (in-hash h2))] (hash-set h (+ offset pos) val)))
(define (find-all-marks/type r mtype)
(define (walk r)
(if (set-member? (rope-marks r) mtype)
(let-values (((lo hi) (rope-lo+hi r)))
(mark-union (walk (rope-left r))
(mark-union (hash-ref (rope-mark-index r) mtype (lambda () (hash)))
(walk (rope-right r))
hi)
lo))
(hash)))
(walk r))
(define (splay-to-pos what r0 pos [extra (lambda () "")])
(define-values (found? r1) (splay-to r0 find-position pos))
(when (not found?) (error what "Invalid position ~a~a" pos (extra)))
r1)
(define (add-mark-to-table old-marks mtype pos value)
(define old-mark (hash-ref old-marks mtype (lambda () (hash))))
(hash-set old-marks mtype (hash-set old-mark pos value)))
(define (set-mark r0 mtype position value)
(define r (splay-to-pos 'set-mark r0 position (lambda () (format " setting mark ~a" mtype))))
(reindex
(if (rope-empty? r)
(rope (empty-strand)
(empty-rope)
(empty-rope)
'will-be-recomputed
'will-be-recomputed
(hasheq mtype (hash position value)))
(struct-copy rope r [mark-index (add-mark-to-table (rope-mark-index r)
mtype
(- position (rope-lo r))
value)]))))
(define (clear-mark r0 mtype position)
(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))
(set-mark (if pos (clear-mark r0 mtype pos) r0) mtype new-pos new-value))
(define (clear-all-marks r)
(and r
(struct-copy rope r
[marks* (seteq)]
[mark-index (hasheq)]
[left (clear-all-marks (rope-left r))]
[right (clear-all-marks (rope-right r))])))
(define (rope-size r)
(if r (rope-size* r) 0))
(define (rope-marks r)
(if r (rope-marks* r) (seteq)))
(define (reindex r)
(struct-copy rope r
[size* (+ (rope-size (rope-left r))
(rope-size (rope-right r))
(strand-count (rope-strand r)))]
[marks* (set-union (rope-marks (rope-left r))
(rope-marks (rope-right r))
(list->seteq (hash-keys (rope-mark-index r))))]))
(define (rope-split r0 position)
(match (splay-to-pos 'rope-split r0 position)
[(? rope-empty?) (values (empty-rope) (empty-rope))]
[(and r (rope t rl rr size marks mark-index))
;; We know the position is in the root of r.
(define-values (lo hi) (rope-lo+hi r))
(define offset (- position lo))
(define-values (left-index right-index) (partition-mark-index mark-index offset))
(define left-strand (substrand t 0 offset))
(define right-strand (substrand t offset))
(values (if (and (strand-empty? left-strand) (hash-empty? left-index))
rl
(reindex
(rope left-strand rl (empty-rope) 'will-be-recomputed (seteq) left-index)))
(if (and (strand-empty? right-strand) (hash-empty? right-index))
rr
(reindex
(rope right-strand (empty-rope) rr 'will-be-recomputed (seteq) right-index))))]))
(define (partition-mark-index index offset)
(for*/fold [(l (hasheq)) (r (hasheq))]
[((mtype posvals) (in-hash index))
((pos val) (in-hash posvals))]
(values (if (or (< pos offset) (and (= pos offset) (eq? (mark-type-stickiness mtype) 'left)))
(add-mark-to-table l mtype pos val)
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)
(cond
[(rope-empty? rl0) rr0]
[(rope-empty? rr0) rl0]
[else
(define-values (_l rl) (splay-to rl0 find-position (rope-size rl0)))
(define-values (_r rr) (splay-to rr0 find-position 0))
;; Both rl's right and rr's left are (empty-rope).
(define t (strand-maybe-append (rope-strand rl) (rope-strand rr)))
(if t
(let ((merged-index (merge-mark-indexes (rope-mark-index rl)
(rope-mark-index rr)
(strand-count (rope-strand rl)))))
(reindex (rope t (rope-left rl) (rope-right rr) 'will-be-recomputed (seteq) merged-index)))
(replace-right rl rr))]))
(define (rope-concat rs)
(foldr rope-append (empty-rope) rs))
(define (merge-mark-indexes li ri offset)
(for*/fold [(i li)]
[((mtype posvals) (in-hash ri))
((pos val) (in-hash posvals))]
(add-mark-to-table i mtype (+ pos offset) val)))
(define (subrope r0 [lo0 #f] [hi0 #f])
(define lo (compute-range-index lo0 0 (rope-size r0)))
(define hi (compute-range-index hi0 (rope-size r0) (rope-size r0)))
(define-values (_l mr) (rope-split r0 lo))
(define-values (m _r) (rope-split mr (- hi lo)))
m)
(define (rope-generator r #:forward? [forward? #t])
(if forward?
(generator ()
(let outer ((r r))
(and r
(begin (outer (rope-left r))
(match-let (((strand text offset count) (rope-strand r)))
(do ((i 0 (+ i 1)))
((= i count))
(yield (string-ref text (+ offset i)))))
(outer (rope-right r))))))
(generator ()
(let outer ((r r))
(and r
(begin (outer (rope-right r))
(match-let (((strand text offset count) (rope-strand r)))
(do ((i (- count 1) (- i 1)))
((negative? i))
(yield (string-ref text (+ offset i)))))
(outer (rope-left r))))))))
(define (rope-seek r0 pos)
(splay-to-pos 'rope-seek r0 pos))
;; (require racket/trace)
;; (trace splay-to find-position rope-concat rope-append rope-split rope->string)
(module+ test
(require (only-in racket/string string-append*))
(check-equal? (rope-size (empty-rope)) 0)
(define-syntax-rule (find-mark/values arg ...)
(match (find-mark arg ...)
[(cons p v) (values p v)]
[#f (values #f #f)]))
(define mtype1 (mark-type "Mark1" 'left))
(define mtype2 (mark-type "Mark2" 'right))
(define (test-with-pieces string-pieces)
(define rope-pieces (map string->rope string-pieces))
(define text (string-append* string-pieces))
(check-equal? (rope->string (car rope-pieces)) (car string-pieces))
(check-equal? (rope->string (rope-concat rope-pieces)) text)
(check-equal? (rope-size (rope-concat rope-pieces)) (string-length text))
(check-eq? (rope-append (empty-rope) (car rope-pieces)) (car rope-pieces))
(check-eq? (rope-append (car rope-pieces) (empty-rope)) (car rope-pieces))
(let loop ((n 1000) (r0 (rope-concat rope-pieces)))
(when (positive? n)
(define pos (random (+ (rope-size r0) 1)))
;; (pretty-print (list pos r0))
(define-values (found? r) (splay-to r0 find-position pos))
(check-true found?)
(check-equal? (rope->string r) text)
(loop (- n 1) r)))
(let*-values (((r) (set-mark (rope-concat rope-pieces) mtype1 9 "original"))
((_) (check-equal? (rope->string r) text))
((pos val) (find-mark/values r mtype1))
((_) (check-equal? pos 9))
((_) (check-equal? val "original"))
((r) (clear-mark r mtype1 pos))
((_) (check-equal? (find-all-marks/type r mtype1) (hash)))
((pos val) (find-mark/values r mtype1))
((_) (check-false pos))
((_) (check-false val))
((r) (set-mark r mtype1 9 "second"))
((pos val) (find-mark/values r mtype1))
((_) (check-equal? pos 9))
((_) (check-equal? val "second"))
((r) (set-mark r mtype1 6 "first"))
((r) (set-mark r mtype2 6 "third"))
((_) (check-equal? (find-all-marks/type r mtype1) (hash 6 "first" 9 "second")))
((_) (check-equal? (find-all-marks/type r mtype2) (hash 6 "third")))
((pos val) (find-mark/values r mtype1 #:forward? #f))
((_) (check-equal? pos 9))
((_) (check-equal? val "second"))
((pos val) (find-mark/values r mtype1))
((_) (check-equal? pos 6))
((_) (check-equal? val "first"))
((l r) (rope-split r pos))
((_) (check-equal? (find-all-marks/type r mtype1) (hash 3 "second")))
((_) (check-equal? (find-all-marks/type l mtype1) (hash 6 "first")))
((_) (check-equal? (find-all-marks/type r mtype2) (hash 0 "third")))
((_) (check-equal? (find-all-marks/type l mtype2) (hash)))
((_) (check-equal? (rope->string l) (substring text 0 6)))
((_) (check-equal? (rope->string r) (substring text 6 (string-length text))))
((_) (check-equal? (rope-marks l) (seteq mtype1)))
((_) (check-equal? (rope-marks r) (seteq mtype1 mtype2)))
((l r) (rope-split r 3))
((_) (check-equal? (find-all-marks/type r mtype1) (hash)))
((_) (check-equal? (find-all-marks/type l mtype1) (hash 3 "second")))
((_) (check-equal? (find-all-marks/type r mtype2) (hash)))
((_) (check-equal? (find-all-marks/type l mtype2) (hash 0 "third")))
((_) (check-equal? (rope->string l) (substring text 6 9)))
((_) (check-equal? (rope->string r) (substring text 9 (string-length text)))))
(void)))
(define prejudice-pieces
(list "It is a truth universally acknowledged, that a single man in possession of a good fortune must be in want of a wife.\n"
"\n"
"However little known the feelings or views of such a man may be on his first entering a neighbourhood, this truth is so well fixed in the minds of the surrounding families, that he is considered as the rightful property of some one or other of their daughters.\n"
"\n"
"``My dear Mr. Bennet,'' said his lady to him one day, ``have you heard that Netherfield Park is let at last?''\n"
"\n"
"Mr. Bennet replied that he had not.\n"))
(define (atomize-pieces pieces)
(map string (string->list (string-append* pieces))))
(test-with-pieces (list "hello" ", " "world"))
(test-with-pieces prejudice-pieces)
(test-with-pieces (atomize-pieces prejudice-pieces))
(check-equal? (call-with-values (lambda () (rope-split (empty-rope) 0)) list)
(list (empty-rope) (empty-rope)))
(check-equal? (map rope->string
(call-with-values (lambda () (rope-split (string->rope "abc") 0)) list))
(list "" "abc"))
(check-equal? (map rope->string
(call-with-values (lambda () (rope-split (string->rope "abc") 2)) list))
(list "ab" "c"))
(check-equal? (map rope->string
(call-with-values (lambda () (rope-split (string->rope "abc") 3)) list))
(list "abc" ""))
(check-equal? (map (lambda (i) (compute-range-index i 'default 10))
(list 0 10 3 -1 -2 11 12 -8 -9 -10 -11 -12))
(list 0 10 3 9 8 10 10 2 1 0 0 0))
(let* ((r (rope-append (string->rope (make-string 10 #\a))
(string->rope (make-string (* 2 *glom-up-to*) #\z))))
(_ (check-equal? (rope-size r) (+ 10 (* 2 *glom-up-to*))))
(r (set-mark r mtype1 (rope-size r) #t))
(r (splay-to-pos 'testing r 0))
(pos (find-mark-pos r mtype1)))
(check-equal? pos 266))
(let*-values (((r) (string->rope "hello"))
((r) (set-mark r mtype2 (rope-size r) #t))
((l r) (rope-split r (find-mark-pos r mtype2)))
((_) (check-equal? (rope->string l) "hello"))
((_) (check-equal? (rope->string r) ""))
((_) (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))
)

138
rmacs/search.rkt
View File

@ -1,138 +0,0 @@
#lang racket/base
;; Knuth-Morris-Pratt string & rope search.
(provide search-generator
search-string
search-rope
findf-in-generator
findf-in-rope)
(require racket/set)
(require racket/match)
(require racket/generator)
(require "rope.rkt")
(define (table pattern)
(define t (make-vector (- (string-length pattern) 1)))
(vector-set! t 0 0)
(let loop ((pos 1) (candidate 0))
(cond
[(= pos (- (string-length pattern) 1))
t]
[(equal? (string-ref pattern pos)
(string-ref pattern candidate))
(vector-set! t pos (+ candidate 1))
(loop (+ pos 1)
(+ candidate 1))]
[(> candidate 0)
(loop pos
(vector-ref t candidate))]
[else
(vector-set! t pos 0)
(loop (+ pos 1)
0)])))
;; String (Generator Char) -> (Option Index)
(define (search-generator needle haystack)
(define t (table needle))
(define cache #f)
(define (advance!)
(define next (haystack))
(set! cache (and (char? next) next)))
(advance!)
(let loop ((m 0) (i 0))
(cond
[(not cache)
#f]
[(equal? (string-ref needle i) cache)
(if (= i (- (string-length needle) 1))
m
(begin (advance!)
(loop m (+ i 1))))]
[(> i 0)
(define ti (vector-ref t (- i 1)))
(loop (- (+ m i) ti) ti)]
[else
(advance!)
(loop (+ m 1) i)])))
;; String String -> (Option Index)
(define (search-string needle haystack)
(define t (table needle))
(let loop ((m 0) (i 0))
(cond
[(= (+ m i) (string-length haystack))
#f]
[(equal? (string-ref needle i) (string-ref haystack (+ m i)))
(if (= i (- (string-length needle) 1))
m
(loop m (+ i 1)))]
[(> i 0)
(define ti (vector-ref t (- i 1)))
(loop (- (+ m i) ti) ti)]
[else
(loop (+ m 1) i)])))
;; String Rope -> (Option Index)
(define (search-rope needle haystack #:forward? [forward? #t])
(if forward?
(search-generator needle (rope-generator haystack))
(let ((reversed-result (search-generator (list->string (reverse (string->list needle)))
(rope-generator haystack #:forward? #f))))
(and reversed-result (- (rope-size haystack) reversed-result (string-length needle))))))
(define (findf-in-generator f gen)
(let loop ((count 0))
(match (gen)
[(? char? c)
(if (f c)
count
(loop (+ count 1)))]
[_ count])))
(define (findf-in-rope f r #:forward? [forward? #t])
(if forward?
(findf-in-generator f (rope-generator r))
(- (rope-size r) (findf-in-generator f (rope-generator r #:forward? #f)))))
(module+ test
(require rackunit)
(check-equal? (table "ABCDABD")
(vector 0 0 0 0 1 2))
(check-equal? (table "PARTICIPATE IN PARACHUTE")
(vector 0 0 0 0 0 0 0 1 2 0 0 0 0 0 0 1 2 3 0 0 0 0 0))
(check-equal? (search-string "ABCDABD" "ABC ABCDAB ABCDABCDABDE") 15)
(check-equal? (search-string "AAAA" "AAABAAABAAABAAABAAAB") #f)
(check-equal? (search-generator "ABCDABD" (sequence->generator "ABC ABCDAB ABCDABCDABDE")) 15)
(check-equal? (search-generator "AAAA" (sequence->generator "AAABAAABAAABAAABAAAB")) #f)
(define prejudice-rope
(rope-concat
(map string->rope
(list "It is a truth universally acknowledged, that a single man in possession of a good fortune must be in want of a wife.\n"
"\n"
"However little known the feelings or views of such a man may be on his first entering a neighbourhood, this truth is so well fixed in the minds of the surrounding families, that he is considered as the rightful property of some one or other of their daughters.\n"
"\n"
"``My dear Mr. Bennet,'' said his lady to him one day, ``have you heard that Netherfield Park is let at last?''\n"
"\n"
"Mr. Bennet replied that he had not.\n"))))
(check-equal? (search-rope "man" prejudice-rope) 54)
(check-equal? (search-rope "man" prejudice-rope #:forward? #f) 171)
(check-equal? (search-rope "man in" prejudice-rope) 54)
(check-equal? (search-rope "man may" prejudice-rope) 171)
(check-equal? (search-rope "man may" prejudice-rope #:forward? #f) 171)
(check-equal? (search-rope "xylophone" prejudice-rope) #f)
(check-equal? (search-rope "xylophone" prejudice-rope #:forward? #f) #f)
(define (find-in-rope delims r)
(define chs (list->set (string->list delims)))
(findf-in-rope (lambda (c) (set-member? chs c)) r))
(check-equal? (find-in-rope "\n" prejudice-rope) 116)
(check-equal? (find-in-rope "at" prejudice-rope) 1)
(check-equal? (find-in-rope "z" prejudice-rope) (rope-size prejudice-rope))
(check-equal? (find-in-rope "\n" prejudice-rope #:forward? #f) (rope-size prejudice-rope))
(check-equal? (find-in-rope "at" prejudice-rope #:forward? #f) (- (rope-size prejudice-rope) 2))
(check-equal? (find-in-rope "z" prejudice-rope #:forward? #f) 0))

18
rmacs/strings.rkt
View File

@ -1,18 +0,0 @@
#lang racket/base
;; String utilities :-(
(provide string-prefix?)
(define (string-prefix? a b [string=? string=?])
(define a-len (string-length a))
(and (>= (string-length b) a-len)
(string=? (substring b 0 a-len) a)))
(module+ test
(require rackunit)
(check-true (string-prefix? "aaa" "aaaa"))
(check-false (string-prefix? "aaaa" "aaa"))
(check-false (string-prefix? "a" "z"))
(check-false (string-prefix? "z" "a"))
(check-true (string-prefix? "a" "a"))
)

54
rmacs/topsort.rkt
View File

@ -1,54 +0,0 @@
#lang racket/base
(provide topsort)
(require racket/match)
(define (topsort edges
#:comparison [comparison equal?])
(define hash-ctor (cond [(eq? comparison equal?) hash]
[(eq? comparison eq?) hasheq]
[else (error 'topsort "Invalid comparison ~v" comparison)]))
(define-values (fwd rev)
(for/fold [(fwd (hash-ctor)) (rev (hash-ctor))]
[(edge edges)]
(match-define (list source target) edge)
(values (hash-set fwd source (hash-set (hash-ref fwd source hash-ctor) target #t))
(hash-set rev target (hash-set (hash-ref rev target hash-ctor) source #t)))))
(define roots (for/fold [(roots (hash-ctor))]
[(source (in-hash-keys fwd))]
(if (hash-has-key? rev source)
roots
(hash-set roots source #t))))
(if (hash-empty? roots)
(if (and (hash-empty? fwd) (hash-empty? rev))
'() ;; no nodes at all
#f) ;; no nodes without incoming edges -> cycle
(let/ec return
(define seen (hash-ctor))
(define busy (hash-ctor))
(define acc '())
(define (visit-nodes nodes)
(for ((n nodes))
(when (hash-has-key? busy n) (return #f)) ;; cycle
(when (not (hash-has-key? seen n))
(set! busy (hash-set busy n #t))
(visit-nodes (hash-keys (hash-ref fwd n hash-ctor)))
(set! seen (hash-set seen n #t))
(set! busy (hash-remove busy n))
(set! acc (cons n acc)))))
(visit-nodes (hash-keys roots))
acc)))
(module+ test
(require rackunit)
(check-equal? (topsort '()) '())
(check-equal? (topsort '((1 1))) #f)
(check-equal? (topsort '((1 0) (0 1))) #f)
(check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 0) (0 1))) #f)
(check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 1) (0 1))) #f)
(check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (0 1))) '(0 1 3 4 2)) ;; others also valid
)

67
rmacs/window.rkt
View File

@ -1,67 +0,0 @@
#lang racket/base
(provide (except-out (struct-out window) window set-window-buffer!)
(rename-out [set-window-buffer!* set-window-buffer!])
make-window
window-editor
window-command
window-mark!
window-move-to!
)
(require racket/match)
(require "buffer.rkt")
(require "rope.rkt")
(struct window (id ;; Symbol
top ;; MarkType
point ;; MarkType
mark ;; MarkType
[buffer #:mutable] ;; (Option Buffer)
[status-line? #:mutable] ;; Boolean
) #:prefab)
(define (make-window initial-buffer #:point [initial-point-or-mark 0])
(define id (gensym 'window))
(define w (window id
(mark-type (buffer-mark-type 'top id #f) 'left)
(mark-type (buffer-mark-type 'point id #t) 'right)
(mark-type (buffer-mark-type 'mark id #f) 'left)
#f
#t))
(set-window-buffer!* w initial-buffer initial-point-or-mark) ;; sets initial marks
w)
(define (window-editor w)
(and (window-buffer w)
(buffer-editor (window-buffer w))))
(define (set-window-buffer!* win new [point-or-mark 0])
(define old (window-buffer win))
(when old
(buffer-clear-mark! old (window-top win))
(buffer-clear-mark! old (window-point win))
(buffer-clear-mark! old (window-mark win)))
(set-window-buffer! win new)
(when new
(buffer-mark! new (window-point win) point-or-mark))
(void))
(define (window-command selector window
#:editor [editor #f]
#:keyseq [keyseq #f]
#:prefix-arg [prefix-arg '#:default])
(command selector (window-buffer window)
#:window window
#:editor editor
#:keyseq keyseq
#:prefix-arg prefix-arg))
(define (window-mark! win [pos (window-point win)])
(buffer-mark! (window-buffer win) (window-mark win) pos)
win)
(define (window-move-to! win pos)
(buffer-mark! (window-buffer win) (window-point win) pos)
win)

57
rmacs/wrap.rkt
View File

@ -1,57 +0,0 @@
#lang racket/base
(provide (struct-out wrap)
wrap-line-count
basic-wrap
buffer-lines-reverse/wrap
buffer-lines-forward/wrap)
(require racket/generator)
(require "buffer.rkt")
(struct wrap (width ;; Nat
points ;; (List Nat)
eol-pos ;; Nat
) #:prefab)
;; Soft-wraps the line starting at sol-pos to the given width.
(define (basic-wrap buf sol-pos width)
(define eol-pos (buffer-end-of-line buf sol-pos))
(let loop ((soft-sol-pos sol-pos)
(points '()))
(define next-sol (buffer-closest-pos-for-column buf soft-sol-pos 0 width))
(if (< next-sol eol-pos)
(loop next-sol (cons next-sol points))
(wrap width (reverse points) eol-pos))))
(define (wrap-line-count w)
(+ 1 (length (wrap-points w))))
(define (buffer-lines-reverse/wrap buf pos-or-mtype wrap-fn width)
(define start-pos (buffer-pos buf pos-or-mtype))
(generator ()
(let hard-break ((eol-pos (buffer-end-of-line buf start-pos)))
(if (< eol-pos 0)
(values #f #f)
(let* ((sol-pos (buffer-start-of-line buf eol-pos))
(w (wrap-fn buf sol-pos width)))
(let soft-break ((eol eol-pos) (ps (reverse (wrap-points w))))
(if (null? ps)
(begin (yield sol-pos eol)
(hard-break (- sol-pos 1)))
(begin (when (<= (car ps) start-pos) (yield (car ps) eol))
(soft-break (car ps) (cdr ps))))))))))
(define (buffer-lines-forward/wrap buf pos-or-mtype wrap-fn width)
(define start-pos (buffer-pos buf pos-or-mtype))
(generator ()
(let hard-break ((sol-pos (buffer-start-of-line buf start-pos)))
(if (> sol-pos (buffer-size buf))
(values #f #f)
(let* ((w (wrap-fn buf sol-pos width)))
(let soft-break ((sol sol-pos) (ps (wrap-points w)))
(if (null? ps)
(begin (yield sol (wrap-eol-pos w))
(hard-break (+ (wrap-eol-pos w) 1)))
(begin (when (> (car ps) start-pos) (yield sol (car ps)))
(soft-break (car ps) (cdr ps))))))))))