diff --git a/Makefile b/Makefile index ebb226b..8fe3e68 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ PACKAGENAME=ansi -COLLECTS=ansi rmacs +COLLECTS=ansi all: setup diff --git a/rmacs/TODO b/rmacs/TODO deleted file mode 100644 index b7668d0..0000000 --- a/rmacs/TODO +++ /dev/null @@ -1,4 +0,0 @@ -Make it reloadable - -Catch and handle SIGWINCH. -See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html diff --git a/rmacs/api.rkt b/rmacs/api.rkt deleted file mode 100644 index eeb68e6..0000000 --- a/rmacs/api.rkt +++ /dev/null @@ -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")) diff --git a/rmacs/buffer.rkt b/rmacs/buffer.rkt deleted file mode 100644 index 12b9ac4..0000000 --- a/rmacs/buffer.rkt +++ /dev/null @@ -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))]))) diff --git a/rmacs/circular-list.rkt b/rmacs/circular-list.rkt deleted file mode 100644 index 7586979..0000000 --- a/rmacs/circular-list.rkt +++ /dev/null @@ -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))) - diff --git a/rmacs/diff.rkt b/rmacs/diff.rkt deleted file mode 100644 index 5e1c637..0000000 --- a/rmacs/diff.rkt +++ /dev/null @@ -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)))))) diff --git a/rmacs/display.rkt b/rmacs/display.rkt deleted file mode 100644 index c6b088e..0000000 --- a/rmacs/display.rkt +++ /dev/null @@ -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)))) diff --git a/rmacs/editor.rkt b/rmacs/editor.rkt deleted file mode 100644 index 3b3290d..0000000 --- a/rmacs/editor.rkt +++ /dev/null @@ -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 "--------------------------------------------------------------------------------")) diff --git a/rmacs/file.rkt b/rmacs/file.rkt deleted file mode 100644 index adcf2b1..0000000 --- a/rmacs/file.rkt +++ /dev/null @@ -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)))) diff --git a/rmacs/info.rkt b/rmacs/info.rkt deleted file mode 100644 index 886963b..0000000 --- a/rmacs/info.rkt +++ /dev/null @@ -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")) diff --git a/rmacs/keys.rkt b/rmacs/keys.rkt deleted file mode 100644 index 20c02ce..0000000 --- a/rmacs/keys.rkt +++ /dev/null @@ -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))))) - ) diff --git a/rmacs/lists.rkt b/rmacs/lists.rkt deleted file mode 100644 index e334180..0000000 --- a/rmacs/lists.rkt +++ /dev/null @@ -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))) diff --git a/rmacs/main.rkt b/rmacs/main.rkt deleted file mode 100644 index e4d632d..0000000 --- a/rmacs/main.rkt +++ /dev/null @@ -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))))) - ) diff --git a/rmacs/minibuf.rkt b/rmacs/minibuf.rkt deleted file mode 100644 index ddf8792..0000000 --- a/rmacs/minibuf.rkt +++ /dev/null @@ -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 "" - (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))) diff --git a/rmacs/mode.rkt b/rmacs/mode.rkt deleted file mode 100644 index f9729c6..0000000 --- a/rmacs/mode.rkt +++ /dev/null @@ -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)) diff --git a/rmacs/mode/fundamental.rkt b/rmacs/mode/fundamental.rkt deleted file mode 100644 index 5b71d4a..0000000 --- a/rmacs/mode/fundamental.rkt +++ /dev/null @@ -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 "" - (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 "" - (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 "" - (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 "" - (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 "" - (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 "" - (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 "" - #: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 "" - #: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-" - #:bind-key "" - (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-" - (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)))) diff --git a/rmacs/render.rkt b/rmacs/render.rkt deleted file mode 100644 index addf7ba..0000000 --- a/rmacs/render.rkt +++ /dev/null @@ -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)) diff --git a/rmacs/rope.rkt b/rmacs/rope.rkt deleted file mode 100644 index c56460e..0000000 --- a/rmacs/rope.rkt +++ /dev/null @@ -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)) - ) diff --git a/rmacs/search.rkt b/rmacs/search.rkt deleted file mode 100644 index 3e5946c..0000000 --- a/rmacs/search.rkt +++ /dev/null @@ -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)) diff --git a/rmacs/strings.rkt b/rmacs/strings.rkt deleted file mode 100644 index fb5c38e..0000000 --- a/rmacs/strings.rkt +++ /dev/null @@ -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")) - ) diff --git a/rmacs/topsort.rkt b/rmacs/topsort.rkt deleted file mode 100644 index 72d8fdf..0000000 --- a/rmacs/topsort.rkt +++ /dev/null @@ -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 - ) diff --git a/rmacs/window.rkt b/rmacs/window.rkt deleted file mode 100644 index 657d19d..0000000 --- a/rmacs/window.rkt +++ /dev/null @@ -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) diff --git a/rmacs/wrap.rkt b/rmacs/wrap.rkt deleted file mode 100644 index 8974525..0000000 --- a/rmacs/wrap.rkt +++ /dev/null @@ -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))))))))))