├── .gitignore ├── COPYING ├── Makefile ├── README.md ├── gpl.txt ├── info.rkt ├── lgpl.txt └── rmacs ├── TODO ├── api.rkt ├── buffer.rkt ├── circular-list.rkt ├── colorize.rkt ├── display-gui-check.rkt ├── display-gui.rkt ├── display-terminal.rkt ├── display.rkt ├── editor.rkt ├── file.rkt ├── history.rkt ├── info.rkt ├── keys.rkt ├── lists.rkt ├── local.rkt ├── main.rkt ├── mark.rkt ├── minibuf.rkt ├── mode.rkt ├── mode └── fundamental.rkt ├── render.rkt ├── ring.rkt ├── rope.rkt ├── rope ├── index.rkt ├── piece.rkt ├── range.rkt ├── string.rkt └── test.rkt ├── search.rkt ├── strings.rkt ├── syntax.rkt ├── timing.rkt ├── topsort.rkt ├── window.rkt └── wrap.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | rmacs: An EMACS written in and for Racket. 2 | Copyright (C) 2011, 2013, 2014, 2015, 2016 Tony Garnock-Jones 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Lesser General Public License as 6 | published by the Free Software Foundation, either version 3 of the 7 | License, or (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, but 10 | WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public 15 | License along with this program (see the files "lgpl.txt" and 16 | "gpl.txt"). If not, see . 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGENAME=rmacs 2 | COLLECTS=rmacs 3 | 4 | all: setup 5 | 6 | clean: 7 | find . -name compiled -type d | xargs rm -rf 8 | 9 | setup: 10 | raco setup $(COLLECTS) 11 | 12 | link: 13 | raco pkg install --link -n $(PACKAGENAME) $$(pwd) 14 | 15 | unlink: 16 | raco pkg remove $(PACKAGENAME) 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # rmacs 2 | 3 | An EMACS written in Racket. Runs in ANSI-compatible terminals. 4 | 5 | ## Installation instructions 6 | 7 | rmacs is still very beta. 8 | 9 | ### Installing using the Racket package system 10 | 11 | Run 12 | 13 | raco pkg install rmacs 14 | 15 | After that, `rmacs` should be on your path. 16 | 17 | ### Installing from git 18 | 19 | After cloning the repo, install the 20 | [racket-ansi](https://github.com/tonyg/racket-ansi) package: 21 | 22 | raco pkg install ansi 23 | 24 | Then, run `make link`, which will install the package from the local 25 | git working tree. 26 | 27 | After `make link` has successfully run once, you don't need to do it 28 | again; running plain `make` or `raco setup rmacs` will recompile the 29 | rmacs package in-place. 30 | 31 | ## License 32 | 33 | Copyright (C) 2011, 2013, 2014, 2015, 2016 Tony Garnock-Jones 34 | 35 | This program is free software: you can redistribute it and/or modify 36 | it under the terms of the GNU Lesser General Public License as 37 | published by the Free Software Foundation, either version 3 of the 38 | License, or (at your option) any later version. 39 | 40 | This program is distributed in the hope that it will be useful, but 41 | WITHOUT ANY WARRANTY; without even the implied warranty of 42 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 43 | Lesser General Public License for more details. 44 | 45 | You should have received a copy of the GNU Lesser General Public 46 | License along with this program (see the files "lgpl.txt" and 47 | "gpl.txt"). If not, see . 48 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define collection 'multi) 3 | (define deps '("base" "ansi" "syntax-color-lib" 4 | "gui-lib" 5 | "unix-signals" 6 | "diff-merge" 7 | ;; this for error reporting (only): 8 | "web-server-lib" 9 | ;; plus these, needed for the tests: 10 | "profile-lib" 11 | )) 12 | (define build-deps '("rackunit-lib")) 13 | -------------------------------------------------------------------------------- /lgpl.txt: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /rmacs/TODO: -------------------------------------------------------------------------------- 1 | Bugs in colorizing unicode -- see diff.rkt, which gets color skew 2 | because of the unicode quotes in the comment block at the top. 3 | Someone's counting bytes, someone else is counting characters. 4 | 5 | Make it reloadable 6 | 7 | Catch and handle SIGWINCH. 8 | See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html 9 | 10 | dabbrev-expand! 11 | 12 | motion word-by-word, motion sexp-by-sexp 13 | 14 | racket-mode 15 | 16 | mutability marks and checks during edits, motion 17 | 18 | maybe make the `unhandled-command` code in `invoke` send an event 19 | rather than hardcoded aborting 20 | 21 | Plan: 22 | - visit-file command 23 | - list-buffers command 24 | 25 | xsel for synchronising the clipboard? 26 | 27 | Figure out some sensible way to implement search-backward-regexp. 28 | - retrying, with exponential doubling of distance from start point? 29 | 30 | isearch 31 | 32 | Modeset signature-set consistency checking. Modes in a modeset must 33 | not have conflicting command signatures - signatures with the same 34 | selector that are not eq?. Because mode command tables are mutable, 35 | perhaps this is best done when a modeset is applied to a buffer? 36 | -------------------------------------------------------------------------------- /rmacs/api.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; API for writing modes/commands/etc. 3 | 4 | (require "mode.rkt") 5 | (require "editor.rkt") 6 | (require "buffer.rkt") 7 | (require "keys.rkt") 8 | (require "rope.rkt") 9 | (require "mark.rkt") 10 | (require "window.rkt") 11 | (require "minibuf.rkt") 12 | (require "local.rkt") 13 | (require "ring.rkt") 14 | (require "history.rkt") 15 | (require "file.rkt") 16 | 17 | (require "circular-list.rkt") 18 | 19 | (provide (all-from-out "mode.rkt" 20 | "editor.rkt" 21 | "buffer.rkt" 22 | "keys.rkt" 23 | "rope.rkt" 24 | "mark.rkt" 25 | "window.rkt" 26 | "minibuf.rkt" 27 | "local.rkt" 28 | "ring.rkt" 29 | "history.rkt" 30 | "file.rkt" 31 | 32 | "circular-list.rkt")) 33 | -------------------------------------------------------------------------------- /rmacs/circular-list.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide circular-list? 4 | circular-empty 5 | circular-null? 6 | circular-pair? 7 | circular-cons 8 | circular-snoc 9 | circular-car 10 | circular-cdr 11 | circular-last 12 | circular-butlast 13 | circular-length 14 | circular-reverse 15 | circular-append 16 | circular-list-ref 17 | circular-list-rotate 18 | circular-list-rotate-forward 19 | circular-list-rotate-backward 20 | list->circular-list 21 | circular-list->list 22 | circular-list-map 23 | circular-list-filter 24 | circular-list-remove 25 | circular-list-memf 26 | circular-list-replacef) 27 | 28 | (require racket/match) 29 | (require (only-in racket/list splitf-at split-at)) 30 | 31 | (struct circular-list ([front #:mutable] 32 | [back #:mutable] 33 | ) #:prefab) 34 | 35 | (define circular-empty (circular-list '() '())) 36 | 37 | (define (circular-null? xs) 38 | (equal? xs circular-empty)) 39 | 40 | (define (circular-pair? xs) 41 | (and (circular-list? xs) 42 | (not (circular-null? xs)))) 43 | 44 | (define (circular-uncons xs) 45 | (cons (circular-car xs) 46 | (circular-cdr xs))) 47 | 48 | (define (circular-unsnoc xs) 49 | (cons (circular-butlast xs) 50 | (circular-last xs))) 51 | 52 | (define (circular-cons* x xs) 53 | (circular-list (cons x (circular-list-front xs)) (circular-list-back xs))) 54 | 55 | (define (circular-snoc* xs x) 56 | (circular-list (circular-list-front xs) (cons x (circular-list-back xs)))) 57 | 58 | (define-match-expander circular-cons 59 | (syntax-rules () [(_ a d) (? circular-pair? (app circular-uncons (cons a d)))]) 60 | (syntax-rules () [(_ a d) (circular-cons* a d)])) 61 | 62 | (define-match-expander circular-snoc 63 | (syntax-rules () [(_ d a) (? circular-pair? (app circular-unsnoc (cons d a)))]) 64 | (syntax-rules () [(_ d a) (circular-snoc* d a)])) 65 | 66 | (define (prime! xs) 67 | (match xs 68 | [(circular-list '() back) 69 | (set-circular-list-front! xs (reverse back)) 70 | (set-circular-list-back! xs '())] 71 | [_ (void)]) 72 | xs) 73 | 74 | (define (anti-prime! xs) 75 | (match xs 76 | [(circular-list front '()) 77 | (set-circular-list-front! xs '()) 78 | (set-circular-list-back! xs (reverse front))] 79 | [_ (void)]) 80 | xs) 81 | 82 | (define (circular-car xs) 83 | (if (circular-null? xs) 84 | (error 'circular-car "Empty circular list") 85 | (car (circular-list-front (prime! xs))))) 86 | 87 | (define (circular-cdr xs) 88 | (if (circular-null? xs) 89 | (error 'circular-cdr "Empty circular list") 90 | (begin (prime! xs) 91 | (circular-list (cdr (circular-list-front xs)) (circular-list-back xs))))) 92 | 93 | (define (circular-last xs) 94 | (if (circular-null? xs) 95 | (error 'circular-last "Empty circular list") 96 | (car (circular-list-back (anti-prime! xs))))) 97 | 98 | (define (circular-butlast xs) 99 | (if (circular-null? xs) 100 | (error 'circular-butlast "Empty circular list") 101 | (begin (anti-prime! xs) 102 | (circular-list (circular-list-front xs) (cdr (circular-list-back xs)))))) 103 | 104 | (define (circular-length xs) 105 | (+ (length (circular-list-front xs)) 106 | (length (circular-list-back xs)))) 107 | 108 | (define (circular-reverse xs) 109 | (circular-list (circular-list-back xs) 110 | (circular-list-front xs))) 111 | 112 | (define (circular-append xs ys) 113 | (circular-list (circular-list-front xs) 114 | (append (circular-list-back ys) 115 | (reverse (circular-list-front ys)) 116 | (circular-list-back xs)))) 117 | 118 | (define (circular-list-ref xs index0) 119 | (define fl (length (circular-list-front xs))) 120 | (define bl (length (circular-list-back xs))) 121 | (define index (modulo index0 (+ fl bl))) 122 | (if (< index fl) 123 | (list-ref (circular-list-front xs) index) 124 | (list-ref (circular-list-back xs) (- (- bl 1) (- index fl))))) 125 | 126 | (define (circular-list-rotate xs count0) 127 | (cond [(circular-null? xs) xs] 128 | [else (define f (circular-list-front xs)) 129 | (define b (circular-list-back xs)) 130 | (define fl (length f)) 131 | (define bl (length b)) 132 | (define count (modulo count0 (+ fl bl))) 133 | (if (<= count fl) 134 | (let-values (((ft fd) (split-at f count))) 135 | (circular-list fd (append (reverse ft) b))) 136 | (let-values (((bt bd) (split-at b (- (+ fl bl) count)))) 137 | (circular-list (append (reverse bt) f) bd)))])) 138 | 139 | (define (circular-list-rotate-forward xs [count 1]) (circular-list-rotate xs count)) 140 | (define (circular-list-rotate-backward xs [count 1]) (circular-list-rotate xs (- count))) 141 | 142 | (define (list->circular-list xs) 143 | (circular-list xs '())) 144 | 145 | (define (circular-list->list xs) 146 | (append (circular-list-front xs) (reverse (circular-list-back xs)))) 147 | 148 | (define (map/reversed-order f xs) 149 | (if (null? xs) 150 | '() 151 | (let ((tail (map/reversed-order f (cdr xs)))) 152 | (cons (f (car xs)) tail)))) 153 | 154 | (define (circular-list-map f xs) 155 | (circular-list (map f (circular-list-front xs)) 156 | (map/reversed-order f (circular-list-back xs)))) 157 | 158 | ;; WARNING: does not preserve order of evaluation wrt back 159 | (define (circular-list-filter f xs) 160 | (circular-list (filter f (circular-list-front xs)) 161 | (filter f (circular-list-back xs)))) 162 | 163 | (define (circular-list-remove item xs [comparison equal?]) 164 | (define new-front (remove item (circular-list-front xs) comparison)) 165 | (if (= (length new-front) (length (circular-list-front xs))) 166 | (circular-list (circular-list-front xs) 167 | (reverse (remove item (reverse (circular-list-back xs)) comparison))) 168 | (circular-list new-front (circular-list-back xs)))) 169 | 170 | (define (circular-list-memf f xs) 171 | (let loop ((seen '()) (xs xs)) 172 | (if (circular-null? xs) 173 | #f 174 | (let ((a (circular-car xs))) 175 | (if (f a) 176 | (circular-list (circular-list-front xs) 177 | (append seen (circular-list-back xs))) 178 | (loop (cons a seen) (circular-cdr xs))))))) 179 | 180 | (define (circular-list-replacef xs finder replacer) 181 | (define (rejecter e) (not (finder e))) 182 | (define-values (head tail) (splitf-at (circular-list-front xs) rejecter)) 183 | (if (null? tail) 184 | (let-values (((head tail) (splitf-at (reverse (circular-list-back xs)) rejecter))) 185 | (if (null? tail) 186 | xs 187 | (circular-list (circular-list-front xs) 188 | (reverse (append head (replacer (car tail)) (cdr tail)))))) 189 | (circular-list (append head (replacer (car tail)) (cdr tail)) 190 | (circular-list-back xs)))) 191 | 192 | (module+ test 193 | (require rackunit) 194 | 195 | (define (check-abcdef abcdef) 196 | (define bcdefa (circular-list-rotate-forward abcdef)) 197 | (check-equal? (circular-length abcdef) 6) 198 | (check-equal? (circular-list->list abcdef) '(a b c d e f)) 199 | (check-equal? (circular-list->list bcdefa) '(b c d e f a)) 200 | (check-equal? (circular-list->list (for/fold [(xs abcdef)] [(i (circular-length abcdef))] 201 | (circular-list-rotate-forward xs))) 202 | (circular-list->list abcdef)) 203 | (check-equal? (circular-list->list (for/fold [(xs abcdef)] [(i (circular-length abcdef))] 204 | (circular-list-rotate-backward xs))) 205 | (circular-list->list abcdef))) 206 | 207 | (check-abcdef (circular-list '(a b c) '(f e d))) 208 | (check-abcdef (circular-list '(a b c d e f) '())) 209 | (check-abcdef (circular-list '() '(f e d c b a))) 210 | 211 | (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d)) 212 | (lambda (x) (eq? x 'e)) 213 | (lambda (x) (list 111)))) 214 | '(a b c d 111 f)) 215 | (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d)) 216 | (lambda (x) (eq? x 'e)) 217 | (lambda (x) (list 111 222)))) 218 | '(a b c d 111 222 f)) 219 | (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d)) 220 | (lambda (x) (eq? x 'b)) 221 | (lambda (x) (list 111)))) 222 | '(a 111 c d e f)) 223 | (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d)) 224 | (lambda (x) (eq? x 'b)) 225 | (lambda (x) (list 111 222)))) 226 | '(a 111 222 c d e f)) 227 | (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d)) 228 | (lambda (x) (eq? x 'x)) 229 | (lambda (x) (list 111 222)))) 230 | '(a b c d e f)) 231 | 232 | (check-equal? (match (circular-cons 1 circular-empty) 233 | [(circular-cons a d) (cons a d)]) 234 | (cons 1 circular-empty)) 235 | (check-equal? (match (circular-list-rotate-forward (circular-cons 1 circular-empty)) 236 | [(circular-cons a d) (cons a d)]) 237 | (cons 1 circular-empty)) 238 | (check-equal? (match (circular-list-rotate-forward 239 | (circular-cons 1 (circular-cons 2 circular-empty))) 240 | [(circular-cons a d) (cons a (circular-list->list d))]) 241 | (list 2 1)) 242 | 243 | (check-equal? (match (circular-snoc circular-empty 1) 244 | [(circular-snoc d a) (cons d a)]) 245 | (cons circular-empty 1)) 246 | (check-equal? (match (circular-list-rotate-forward (circular-snoc circular-empty 1)) 247 | [(circular-snoc d a) (cons d a)]) 248 | (cons circular-empty 1)) 249 | (check-equal? (match (circular-list-rotate-forward 250 | (circular-snoc (circular-snoc circular-empty 2) 1)) 251 | [(circular-snoc d a) (cons a (circular-list->list d))]) 252 | (list 2 1)) 253 | 254 | (check-equal? (match (circular-snoc (circular-snoc circular-empty 1) 2) 255 | [(circular-cons x (circular-cons y z)) (cons x (cons y (circular-list->list z)))]) 256 | (list 1 2)) 257 | 258 | (check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1 2 3) '(6 5 4)))) 259 | '(1 3 4 5 6)) 260 | (check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1) '(6 5 4 3 2)))) 261 | '(1 3 4 5 6)) 262 | (check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1 2 3 2) '(6 5 2 4)))) 263 | '(1 3 2 4 2 5 6)) 264 | (check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1) '(6 5 2 4 2 3 2)))) 265 | '(1 3 2 4 2 5 6)) 266 | 267 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 0) 'a) 268 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 1) 'b) 269 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 2) 'c) 270 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 3) 'd) 271 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 4) 'e) 272 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 5) 'f) 273 | 274 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 6) 'a) 275 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) 10) 'e) 276 | 277 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) -4) 'c) 278 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) -6) 'a) 279 | (check-equal? (circular-list-ref (circular-list '(a b c) '(f e d)) -10) 'c) 280 | 281 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 0) 282 | (circular-list '(a b c) '(f e d))) 283 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 1) 284 | (circular-list '(b c) '(a f e d))) 285 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 2) 286 | (circular-list '(c) '(b a f e d))) 287 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 3) 288 | (circular-list '() '(c b a f e d))) 289 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 4) 290 | (circular-list '(e f a b c) '(d))) 291 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 5) 292 | (circular-list '(f a b c) '(e d))) 293 | 294 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 6) 295 | (circular-list '(a b c) '(f e d))) 296 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) 10) 297 | (circular-list '(e f a b c) '(d))) 298 | 299 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) -4) 300 | (circular-list '(c) '(b a f e d))) 301 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) -6) 302 | (circular-list '(a b c) '(f e d))) 303 | (check-equal? (circular-list-rotate (circular-list '(a b c) '(f e d)) -10) 304 | (circular-list '(c) '(b a f e d))) 305 | 306 | (check-equal? (circular-list-rotate (circular-list '() '(c b a f e d)) 1) 307 | (circular-list '(e f a b c) '(d))) 308 | 309 | (check-equal? (circular-list->list (circular-reverse (circular-list '(a b c) '(f e d)))) 310 | '(f e d c b a)) 311 | (check-equal? (circular-list->list 312 | (circular-append (circular-list '(a b c) '(f e d)) 313 | (circular-list '(g h i) '(l k j)))) 314 | '(a b c d e f g h i j k l)) 315 | ) 316 | -------------------------------------------------------------------------------- /rmacs/colorize.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide colorize-burst) 4 | 5 | (require racket/match) 6 | (require syntax-color/module-lexer) 7 | (require syntax-color/lexer-contract) 8 | (require "rope.rkt") 9 | (require "mark.rkt") 10 | (require "buffer.rkt") 11 | (require "render.rkt") 12 | (require "display.rkt") 13 | 14 | (define colorization-state-mark (mark-type (buffer-mark-type 'colorization-state #f #f) 'right)) 15 | 16 | (struct colorization-state (mode) #:prefab) 17 | 18 | (define colors 19 | (hash 'comment (pen color-red color-black #f #t) 20 | 'sexp-comment (pen color-red color-black #f #t) 21 | 'white-space tty-default-pen 22 | 'symbol tty-default-pen 23 | 'string (pen color-yellow color-black #f #f) 24 | 'constant (pen color-green color-black #f #f) 25 | 'parenthesis tty-default-pen 26 | 'error (pen color-white color-red #f #f) 27 | 'hash-colon-keyword (pen color-cyan color-black #f #f) 28 | 'other (pen color-magenta color-black #f #f) 29 | )) 30 | 31 | (define (strip-colorization! buf) 32 | (buffer-clear-all-marks/type! buf color-mark 0 (buffer-size buf))) 33 | 34 | (define (colorize-burst buf [start-pos0 (buffer-size buf)]) 35 | (match-define-values (start-pos (colorization-state mode)) 36 | (match (buffer-mark* buf colorization-state-mark #:forward? #f #:position start-pos0) 37 | [#f (values 0 (colorization-state #f))] 38 | [(cons pos s) (values pos s)])) 39 | (define-values (_l r) (rope-split (buffer-rope buf) start-pos)) 40 | (define in (rope->searchable-port r)) 41 | (define start-time (current-inexact-milliseconds)) 42 | (let loop ((mode mode)) 43 | (define-values (lexeme type data new-token-start new-token-end backup-delta new-mode) 44 | (module-lexer in start-pos mode)) 45 | ;; (log-info "color ~v mode ~v from ~v gave ~v ~v between ~v-~v" 46 | ;; (buffer-title buf) 47 | ;; mode 48 | ;; start-pos 49 | ;; type 50 | ;; lexeme 51 | ;; new-token-start 52 | ;; new-token-end) 53 | (when (not (zero? backup-delta)) 54 | (log-warning "Non-zero backup-delta ~v seen while colorizing buffer ~v at position ~v" 55 | backup-delta 56 | (buffer-title buf) 57 | start-pos)) 58 | (if (eq? type 'eof) 59 | #f 60 | (let ((pen (hash-ref colors type))) 61 | (when (not (equal? pen tty-default-pen)) 62 | (buffer-mark! buf color-mark (+ start-pos new-token-start -1) 63 | #:value pen #:replace? #f) 64 | (buffer-mark! buf color-mark (+ start-pos new-token-end -1) 65 | #:value tty-default-pen #:replace? #f)) 66 | (if (dont-stop? new-mode) 67 | (loop (dont-stop-val new-mode)) 68 | (begin 69 | (buffer-mark! buf colorization-state-mark (+ start-pos new-token-end -1) 70 | #:value (colorization-state new-mode) #:replace? #f) 71 | (let ((now (current-inexact-milliseconds))) 72 | (if (< (- now start-time) 50) 73 | (loop new-mode) 74 | #t)))))))) 75 | -------------------------------------------------------------------------------- /rmacs/display-gui-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Implicitly requires display-gui.rkt if various conditions hold. 3 | 4 | (require racket/runtime-path) 5 | 6 | (define-runtime-path here ".") 7 | 8 | (when (and (or (eq? (system-type) 'macosx) 9 | (eq? (system-type) 'windows) 10 | (getenv "DISPLAY")) 11 | (not (getenv "RMACS_NO_GUI"))) 12 | (dynamic-require (build-path here "display-gui.rkt") #f)) 13 | -------------------------------------------------------------------------------- /rmacs/display-gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Implicitly provides a factory via display.rkt's `register-tty-backend!`. 3 | 4 | (require racket/set) 5 | (require racket/match) 6 | (require racket/class) 7 | (require racket/gui/base) 8 | (require racket/generic) 9 | (require "display.rkt") 10 | 11 | (struct gui (frame ;; frame% 12 | canvas ;; canvas% 13 | keys-ch ;; Channel 14 | [key-pushback #:mutable] ;; (Option Key) 15 | [screen #:mutable] ;; Screen 16 | ) 17 | #:methods gen:tty 18 | [(define (tty-pending-screen t) (gui-screen t)) 19 | (define (set-tty-pending-screen! t s) (set-gui-screen! t s)) 20 | (define (tty-reset t) (gui-reset t)) 21 | (define (tty-flush t) (send (gui-canvas t) refresh-now)) 22 | (define (tty-set-title! t title) (send (gui-frame t) set-label title)) 23 | (define (tty-next-key t) (gui-next-key t)) 24 | (define (tty-next-key-evt t) (gui-next-key-evt t)) 25 | (define (tty-input-available-evt t) (gui-input-available-evt t))]) 26 | 27 | (define (gui-factory) 28 | (and (or (eq? (system-type) 'macosx) 29 | (eq? (system-type) 'windows) 30 | (getenv "DISPLAY")) 31 | (not (getenv "RMACS_NO_GUI")) 32 | (gui-factory*))) 33 | 34 | (define (gui-factory*) 35 | (parameterize ((current-eventspace (make-eventspace))) 36 | (define keys-ch (make-channel)) 37 | (define frame (new frame% 38 | [label "rmacs"] 39 | [width 640] 40 | [height 480])) 41 | (define g 'uninitialized-gui) 42 | (define (gui-initialized?) (not (eq? g 'uninitialized-gui))) 43 | (define canvas 44 | (new (class canvas% 45 | (super-new) 46 | ;; (define/override (on-event e) 47 | ;; (fprintf (current-error-port) "\r\nevent ~v\r\n" e)) 48 | (define/override (on-size _w _h) 49 | (when (gui-initialized?) (gui-reset g)) 50 | (channel-put keys-ch (key 'window-resize (set)))) 51 | (define/override (on-char e) 52 | (define key-code (send e get-key-code)) 53 | (when (not (set-member? (set 'release 54 | 'shift 55 | 'rshift 56 | 'control 57 | 'rcontrol) 58 | key-code)) 59 | (define control? (send e get-control-down)) 60 | (channel-put 61 | keys-ch 62 | (key (if (and control? (char-alphabetic? key-code)) 63 | (char-upcase key-code) 64 | (match key-code 65 | ['prior 'page-up] 66 | ['next 'page-down] 67 | [#\backspace 'backspace] 68 | [#\rubout 'delete] 69 | [#\return 'return] 70 | [#\tab 'tab] 71 | [other other])) 72 | (list->set 73 | (filter values 74 | (list (and (send e get-shift-down) 'shift) 75 | (and (send e get-alt-down) 'meta) 76 | (and (send e get-meta-down) 'meta) 77 | (and control? 'control)))))))) 78 | ) 79 | [parent frame] 80 | [paint-callback 81 | (lambda (canvas dc) 82 | (when (gui-initialized?) (gui-render g canvas dc)))])) 83 | (set! g (gui frame 84 | canvas 85 | keys-ch 86 | #f 87 | (make-screen 24 80 tty-default-pen))) 88 | (send canvas focus) 89 | (send frame show #t) 90 | (gui-reset g) 91 | g)) 92 | 93 | (define (mkf bold? italic?) 94 | (define size (if (eq? (system-type) 'windows) 11 14)) 95 | (define name (if (eq? (system-type) 'windows) "Consolas" "Inconsolata")) 96 | (make-object font% size name 'default 97 | (if italic? 'italic 'normal) 98 | (if bold? 'bold 'normal))) 99 | 100 | (define *ad-hoc-scale* (if (eq? (system-type) 'windows) 1.3 1)) 101 | 102 | (define fonts 103 | (vector (mkf #f #f) 104 | (mkf #f #t) 105 | (mkf #t #f) 106 | (mkf #t #t))) 107 | 108 | (define (gui-render g canvas dc) 109 | (define s (gui-screen g)) 110 | 111 | (define (lookup-color n) 112 | (match n 113 | [(== color-black) "black"] 114 | [(== color-red) "red"] 115 | [(== color-green) "green"] 116 | [(== color-yellow) "yellow"] 117 | [(== color-blue) "blue"] 118 | [(== color-magenta) "magenta"] 119 | [(== color-cyan) "cyan"] 120 | [(== color-white) "white"])) 121 | 122 | (send dc set-font (vector-ref fonts 0)) 123 | (send dc set-text-mode 'solid) 124 | (send dc set-background "black") 125 | (send dc clear) 126 | 127 | (define default-pen (pen color-white color-black #f #f)) 128 | (define cursor-pen (pen color-white color-green #t #f)) 129 | 130 | (for/fold [(y-offset 0)] 131 | [(row (in-range (screen-rows s)))] 132 | (define current-row-height (* *ad-hoc-scale* (send dc get-char-height))) 133 | (define x-offset 0) 134 | (let loop ((col 0) 135 | (acc-rev '()) 136 | (pen #f)) 137 | (define (finish-chunk!) 138 | (when (pair? acc-rev) 139 | (let ((pen (if (eq? pen 'default) default-pen pen))) 140 | (define line (list->string (reverse acc-rev))) 141 | (send dc set-font (vector-ref fonts 142 | (+ (if (pen-bold? pen) 2 0) 143 | (if (pen-italic? pen) 1 0)))) 144 | (send dc set-text-foreground (lookup-color (pen-foreground-color pen))) 145 | (send dc set-text-background (lookup-color (pen-background-color pen))) 146 | (define-values (w h _descender _verticalspace) 147 | (send dc get-text-extent line)) 148 | (send dc draw-text line x-offset y-offset) 149 | (set! x-offset (+ x-offset w)) 150 | (set! current-row-height (max current-row-height h))))) 151 | (if (= col (screen-columns s)) 152 | (finish-chunk!) 153 | (match (vector-ref (vector-ref (screen-contents s) row) col) 154 | [(cons new-pen ch) 155 | (when (and (= col (screen-cursor-column s)) 156 | (= row (screen-cursor-row s))) 157 | (set! new-pen cursor-pen) 158 | (when (eq? ch 'empty) 159 | (set! ch #\space))) 160 | (cond 161 | [(eq? ch 'empty) 162 | (loop (+ col 1) acc-rev pen)] 163 | [(or (equal? new-pen pen) (not pen)) 164 | (loop (+ col 1) (cons ch acc-rev) new-pen)] 165 | [else 166 | (finish-chunk!) 167 | (loop (+ col 1) (list ch) new-pen)])]))) 168 | (+ y-offset current-row-height))) 169 | 170 | (define (gui-reset g) 171 | (define canvas (gui-canvas g)) 172 | (define-values (width height) (send canvas get-client-size)) 173 | (define dc (send canvas get-dc)) 174 | (send dc set-font (vector-ref fonts 0)) 175 | (define-values (rows columns) 176 | (values (- (inexact->exact (floor (/ height (* *ad-hoc-scale* (send dc get-char-height))))) 0) 177 | (- (inexact->exact (floor (/ width (send dc get-char-width)))) 0))) 178 | (set-gui-screen! g (make-screen rows columns tty-default-pen)) 179 | g) 180 | 181 | (define (gui-next-key g) 182 | (define pb (gui-key-pushback g)) 183 | (if pb 184 | (begin (set-gui-key-pushback! g #f) 185 | pb) 186 | (channel-get (gui-keys-ch g)))) 187 | 188 | (define (gui-next-key-evt g) 189 | (define pb (gui-key-pushback g)) 190 | (if pb 191 | (handle-evt always-evt 192 | (lambda (_) 193 | (set-gui-key-pushback! g #f) 194 | pb)) 195 | (gui-keys-ch g))) 196 | 197 | (define (gui-input-available-evt g) 198 | (define pb (gui-key-pushback g)) 199 | (if pb 200 | always-evt 201 | (handle-evt (gui-keys-ch g) 202 | (lambda (k) 203 | (set-gui-key-pushback! g k) 204 | #t)))) 205 | 206 | (register-tty-backend! 'gui gui-factory #:priority 1) 207 | -------------------------------------------------------------------------------- /rmacs/display-terminal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Implicitly provides a factory via display.rkt's `register-tty-backend!`. 3 | 4 | (provide (struct-out terminal)) 5 | 6 | (require racket/set) 7 | (require racket/match) 8 | (require (only-in racket/vector vector-copy)) 9 | (require (prefix-in ansi: ansi)) 10 | (require unix-signals) 11 | (require "display.rkt") 12 | (require diff-merge/diff) 13 | 14 | (struct terminal (input ;; InputPort 15 | output ;; OutputPort 16 | [displayed-screen #:mutable] ;; Screen 17 | [pending-screen #:mutable] ;; Screen 18 | [utf-8-input? #:mutable] ;; Boolean 19 | [displayed-title #:mutable] ;; (Option String) 20 | [pending-title #:mutable] ;; (Option String) 21 | ) 22 | #:methods gen:tty 23 | [(define (tty-shutdown!! t) (terminal-shutdown t)) 24 | (define (tty-pending-screen t) (terminal-pending-screen t)) 25 | (define (set-tty-pending-screen! t s) (set-terminal-pending-screen! t s)) 26 | (define (tty-reset t) (reset t)) 27 | (define (tty-flush t) (terminal-flush t)) 28 | (define (tty-set-title! t title) (set-terminal-pending-title! t title)) 29 | (define (tty-next-key t) (terminal-next-key t)) 30 | (define (tty-next-key-evt t) (terminal-next-key-evt t)) 31 | (define (tty-input-available-evt t) (terminal-input t))]) 32 | 33 | (define *stdin-tty* #f) 34 | (define (stdin-tty) 35 | (when (not *stdin-tty*) 36 | (capture-signal! 'SIGWINCH) 37 | (ansi:tty-raw!) 38 | (set! *stdin-tty* 39 | (terminal 40 | (current-input-port) 41 | (current-output-port) 42 | (make-screen 24 80 tty-default-pen) 43 | (make-screen 24 80 tty-default-pen) 44 | (match (getenv "RMACS_UTF8_INPUT") 45 | [(or #f "yes" "true" "1") #t] 46 | [(or "no" "false" "0") #f] 47 | [v (error 'RMACS_UTF8_INPUT 48 | "Environment variable RMACS_UTF8_INPUT value ~v invalid: must be in ~v" 49 | v 50 | (list "yes" "true" "1" "no" "false" "0"))]) 51 | #f 52 | #f)) 53 | (reset *stdin-tty*) 54 | (plumber-add-flush! (current-plumber) 55 | (lambda (h) 56 | (terminal-shutdown *stdin-tty*)))) 57 | *stdin-tty*) 58 | 59 | (define (terminal-shutdown t) 60 | (output t 61 | (ansi:select-graphic-rendition ansi:style-normal) 62 | (ansi:goto (tty-rows t) 1) 63 | "\n") 64 | (flush t) 65 | (ansi:tty-restore!)) 66 | 67 | (define (collect-position-report tty) 68 | (let loop () 69 | (sync/timeout 0.5 70 | (handle-evt (terminal-input tty) 71 | (lambda (p) 72 | (match (ansi:lex-lcd-input p) 73 | [(? ansi:position-report? r) r] 74 | [_ (loop)])))))) 75 | 76 | (define (reset tty) 77 | (output tty 78 | (ansi:clear-screen) 79 | (ansi:goto 999 999) 80 | (ansi:position-report-request)) 81 | (flush tty) 82 | (define report (or (collect-position-report tty) 83 | (ansi:position-report 24 80))) ;; TODO: have a more flexible fallback 84 | (define rows (ansi:position-report-row report)) 85 | (define columns (ansi:position-report-column report)) 86 | (set-pen tty tty-default-pen #:force #t) 87 | (clear tty) 88 | (flush tty) 89 | (set-terminal-displayed-screen! tty (make-screen rows columns tty-default-pen)) 90 | (set-terminal-pending-screen! tty (make-screen rows columns tty-default-pen)) 91 | tty) 92 | 93 | (define (set-pen tty p #:force [force #f]) 94 | (when (or force (not (equal? p (screen-pen (terminal-displayed-screen tty))))) 95 | (match p 96 | [(pen fgcolor bgcolor bold? italic?) 97 | (output tty 98 | (apply ansi:select-graphic-rendition 99 | `(,@(if bold? (list ansi:style-bold) (list)) 100 | ,@(if italic? (list ansi:style-italic/inverse) (list)) 101 | ,(ansi:style-text-color fgcolor) 102 | ,(ansi:style-background-color bgcolor))))] 103 | ['default 104 | (output tty (ansi:select-graphic-rendition ansi:style-normal))]) 105 | (set-screen-pen! (terminal-displayed-screen tty) p)) 106 | tty) 107 | 108 | (define (clear tty) 109 | (output tty (ansi:clear-screen/home)) 110 | (set-screen-cursor-row! (terminal-displayed-screen tty) 0) 111 | (set-screen-cursor-column! (terminal-displayed-screen tty) 0) 112 | tty) 113 | 114 | (define (color-near-cursor s row-delta column-delta) 115 | (define r (max 0 (min (- (screen-rows s) 1) (+ (screen-cursor-row s) row-delta)))) 116 | (define c (max 0 (min (- (screen-columns s) 1) (+ (screen-cursor-column s) column-delta)))) 117 | (car (vector-ref (vector-ref (screen-contents s) r) c))) 118 | 119 | (define (vector-delete! v base count fill) 120 | (vector-copy! v base v (+ base count) (vector-length v)) 121 | (for ((i (in-range (- (vector-length v) count) (vector-length v)))) (vector-set! v i fill))) 122 | 123 | (define (vector-insert! v base count fill) 124 | (vector-copy! v (+ base count) v base (- (vector-length v) count)) 125 | (for ((i (in-range base (+ base count)))) (vector-set! v i fill))) 126 | 127 | (define (delete-lines tty n) 128 | (define s (terminal-displayed-screen tty)) 129 | (set-pen tty tty-default-pen) 130 | (output tty (ansi:delete-lines n)) 131 | (define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty))) 132 | (vector-delete! (screen-contents s) (screen-cursor-row s) n blank-line) 133 | tty) 134 | 135 | (define (insert-lines tty n) 136 | (define s (terminal-displayed-screen tty)) 137 | (set-pen tty tty-default-pen) 138 | (output tty (ansi:insert-lines n)) 139 | (define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty))) 140 | (vector-insert! (screen-contents s) (screen-cursor-row s) n blank-line) 141 | tty) 142 | 143 | (define (delete-columns tty n) 144 | (define s (terminal-displayed-screen tty)) 145 | (set-pen tty tty-default-pen) 146 | (output tty (ansi:delete-characters n)) 147 | (define blank-cell (cons (screen-pen s) 'empty)) 148 | (define line (vector-ref (screen-contents s) (screen-cursor-row s))) 149 | (vector-delete! line (screen-cursor-column s) n blank-cell) 150 | tty) 151 | 152 | (define (insert-columns tty n) 153 | (define s (terminal-displayed-screen tty)) 154 | (set-pen tty (color-near-cursor s 0 -1)) 155 | (output tty (ansi:insert-characters n)) 156 | (define blank-cell (cons (screen-pen s) 'empty)) 157 | (define line (vector-ref (screen-contents s) (screen-cursor-row s))) 158 | (vector-insert! line (screen-cursor-column s) n blank-cell) 159 | tty) 160 | 161 | (define (output tty . items) 162 | (for ((i items)) (display i (terminal-output tty)))) 163 | 164 | (define (flush tty) 165 | (flush-output (terminal-output tty))) 166 | 167 | ;;--------------------------------------------------------------------------- 168 | ;; Display to buffered screen 169 | 170 | (define (goto-if-needed s row column) 171 | (cond 172 | [(and (= (screen-cursor-row s) row) (= (screen-cursor-column s) column)) 173 | ""] 174 | [(= (screen-cursor-row s) row) 175 | (begin0 (ansi:goto-column (+ column 1)) 176 | (set-screen-cursor-column! s column))] 177 | [else 178 | (begin0 (ansi:goto (+ row 1) (+ column 1)) 179 | (set-screen-cursor-row! s row) 180 | (set-screen-cursor-column! s column))])) 181 | 182 | (define (advance-cursor! tty s) 183 | (set-screen-cursor-column! s (+ (screen-cursor-column s) 1)) 184 | (when (= (screen-cursor-column s) (screen-columns s)) 185 | (when (< (screen-cursor-row s) (- (screen-rows s) 1)) 186 | (output tty "\r\n")) 187 | (set-screen-cursor-column! s 0) 188 | (set-screen-cursor-row! s (+ (screen-cursor-row s) 1)))) 189 | 190 | ;; Answers #t when an edit to a line would produce a visible effect. 191 | (define (interesting-change? old-line new-line column right-margin) 192 | (for/or [(i (in-range column right-margin))] 193 | (not (equal? (vector-ref old-line i) (vector-ref new-line i))))) 194 | 195 | (define (non-empty? ch) (not (equal? ch 'empty))) 196 | 197 | (define (repair-span! tty old new-line row first-col cell-count) 198 | (define trailing-empty-count 199 | (for/fold [(empty-count 0)] [(column (in-range first-col (+ first-col cell-count)))] 200 | (match-define (cons new-pen new-ch) (vector-ref new-line column)) 201 | (if (non-empty? new-ch) 202 | (begin (set-pen tty new-pen) 203 | (output tty (goto-if-needed old row column) new-ch) 204 | (advance-cursor! tty old) 205 | 0) 206 | (+ empty-count 1)))) 207 | (when (and (positive? trailing-empty-count) (= (+ first-col cell-count) (tty-columns tty))) 208 | (output tty (ansi:clear-to-eol)))) 209 | 210 | ;; patch-indices is a result from a call to diff-indices 211 | (define (apply-patch! patch-indices ;; DiffIndices 212 | remove-elements! ;; Nat Nat -> Void 213 | insert-elements! ;; Nat Nat Nat -> Void 214 | ) 215 | (for/fold [(skew 0)] [(patch patch-indices)] 216 | (match-define (difference old-i old-n new-i new-n) patch) 217 | (define delta (- new-n old-n)) 218 | (if (negative? delta) 219 | (begin (remove-elements! (+ old-i skew) (- delta)) 220 | (+ skew delta)) 221 | skew)) 222 | (for/fold [(skew 0)] [(patch patch-indices)] 223 | (match-define (difference old-i old-n new-i new-n) patch) 224 | (define delta (- new-n old-n)) 225 | (insert-elements! (+ old-i skew) (max 0 delta) new-n) 226 | (+ skew delta)) 227 | (void)) 228 | 229 | (define (repair-line! tty old new row) 230 | (define columns (screen-columns new)) 231 | (define old-line (vector-ref (screen-contents old) row)) 232 | (define new-line (vector-ref (screen-contents new) row)) 233 | (define patches (diff-indices old-line new-line)) 234 | (if (<= (length patches) 3) 235 | (apply-patch! patches 236 | (lambda (first-col cols-to-remove) 237 | (when (interesting-change? old-line new-line first-col columns) 238 | (output tty (goto-if-needed old row first-col)) 239 | (delete-columns tty cols-to-remove))) 240 | (lambda (first-col cols-to-insert cell-count) 241 | (when (interesting-change? old-line new-line first-col columns) 242 | (output tty (goto-if-needed old row first-col)) 243 | (when (and (positive? cols-to-insert) 244 | (interesting-change? old-line 245 | new-line 246 | (+ first-col cols-to-insert) 247 | columns)) 248 | (insert-columns tty cols-to-insert)) 249 | (repair-span! tty old new-line row first-col cell-count)))) 250 | (repair-span! tty old new-line row 0 columns))) 251 | 252 | (define (terminal-flush t) 253 | (define old (terminal-displayed-screen t)) 254 | (define new (terminal-pending-screen t)) 255 | (apply-patch! (diff-indices (screen-contents old) (screen-contents new)) 256 | (lambda (first-row lines-to-remove) 257 | (output t (goto-if-needed old first-row (screen-cursor-column old))) 258 | (delete-lines t lines-to-remove)) 259 | (lambda (first-row lines-to-insert line-count) 260 | (when (positive? lines-to-insert) 261 | (output t (goto-if-needed old first-row (screen-cursor-column old))) 262 | (insert-lines t lines-to-insert)) 263 | (for ((row (in-range first-row (+ first-row line-count)))) 264 | (repair-line! t old new row)))) 265 | (output t (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new))) 266 | (let ((new-title (terminal-pending-title t))) 267 | (when (not (equal? new-title (terminal-displayed-title t))) 268 | (when new-title (output t (ansi:xterm-set-window-title new-title))) 269 | (set-terminal-displayed-title! t new-title))) 270 | (flush t) 271 | (set-terminal-displayed-screen! t (struct-copy screen new [pen (screen-pen old)])) 272 | (set-terminal-pending-screen! t (copy-screen new)) 273 | t) 274 | 275 | ;;--------------------------------------------------------------------------- 276 | ;; Input 277 | 278 | (define (has-control-modifier? modifiers) 279 | (set-member? modifiers 'control)) 280 | 281 | (define (terminal-next-key tty) 282 | (define k (ansi:lex-lcd-input (terminal-input tty) #:utf-8? (terminal-utf-8-input? tty))) 283 | (match k 284 | [(ansi:key #\tab modifiers) (ansi:key 'tab modifiers)] 285 | [(ansi:key #\I (? has-control-modifier? ms)) (ansi:key 'tab (set-remove ms 'control))] 286 | [(ansi:key #\M (? has-control-modifier? ms)) (ansi:key 'return (set-remove ms 'control))] 287 | [(ansi:key #\[ (? has-control-modifier? ms)) ;; ESC 288 | (or (sync/timeout 0.5 289 | (handle-evt (terminal-next-key-evt tty) 290 | (lambda (k) (ansi:add-modifier 'meta k)))) 291 | (ansi:key 'escape (set-remove ms 'control)))] 292 | [_ k])) 293 | 294 | (define (terminal-next-key-evt tty) 295 | (choice-evt (handle-evt next-signal-evt 296 | (lambda (signal-number) 297 | (and (eq? (lookup-signal-name signal-number) 'SIGWINCH) 298 | (key 'window-resize (set))))) 299 | (handle-evt (terminal-input tty) 300 | (lambda (_) (terminal-next-key tty))))) 301 | 302 | (register-tty-backend! 'terminal stdin-tty) 303 | -------------------------------------------------------------------------------- /rmacs/display.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide gen:tty 4 | tty? 5 | tty-shutdown!! 6 | tty-pending-screen 7 | set-tty-pending-screen! 8 | tty-rows 9 | tty-columns 10 | tty-last-row 11 | tty-last-column 12 | tty-cursor-row 13 | tty-cursor-column 14 | tty-display 15 | tty-newline 16 | tty-clear 17 | tty-clear-to-eol 18 | tty-reset 19 | tty-goto 20 | tty-set-pen! 21 | tty-default-pen 22 | tty-pen 23 | tty-flush 24 | tty-set-title! 25 | tty-next-key 26 | tty-next-key-evt 27 | tty-input-available-evt 28 | 29 | (struct-out pen) 30 | 31 | register-tty-backend! 32 | default-tty 33 | 34 | (struct-out screen) 35 | make-screen 36 | copy-screen 37 | screen-last-row 38 | screen-last-column 39 | screen-goto 40 | screen-putc 41 | screen-puts 42 | screen-clear-to-eol 43 | 44 | ;; From ansi. TODO: better color & keyboard abstractions 45 | (struct-out key) 46 | (rename-out [ansi:color-black color-black] 47 | [ansi:color-red color-red] 48 | [ansi:color-green color-green] 49 | [ansi:color-yellow color-yellow] 50 | [ansi:color-blue color-blue] 51 | [ansi:color-magenta color-magenta] 52 | [ansi:color-cyan color-cyan] 53 | [ansi:color-white color-white])) 54 | 55 | (require racket/match) 56 | (require racket/generic) 57 | (require (only-in racket/vector vector-copy)) 58 | (require (prefix-in ansi: (only-in ansi/ansi 59 | color-black 60 | color-red 61 | color-green 62 | color-yellow 63 | color-blue 64 | color-magenta 65 | color-cyan 66 | color-white))) 67 | (require (only-in ansi/lcd-terminal struct:key key key? key-value key-modifiers)) 68 | 69 | ;; A Color is a Nat. TODO: better color abstraction. 70 | 71 | (define-generics tty 72 | (tty-shutdown!! tty) 73 | (tty-pending-screen tty) 74 | (set-tty-pending-screen! tty s) 75 | (tty-reset tty) 76 | (tty-flush tty) 77 | (tty-set-title! tty title) 78 | (tty-next-key tty) 79 | 80 | ;; Do not retain the events returned by these functions across 81 | ;; actual input from the tty! See comment in editor-sit-for, and 82 | ;; implementations of these functions in display-gui.rkt. (The 83 | ;; fragility of the pushback in display-gui.rkt is the cause of this 84 | ;; restriction.) 85 | (tty-next-key-evt tty) 86 | (tty-input-available-evt tty) 87 | ) 88 | 89 | (define (tty-rows t) (screen-rows (tty-pending-screen t))) 90 | (define (tty-columns t) (screen-columns (tty-pending-screen t))) 91 | 92 | (define (tty-last-row t) (- (tty-rows t) 1)) 93 | (define (tty-last-column t) (- (tty-columns t) 1)) 94 | 95 | (define (tty-cursor-row t) (screen-cursor-row (tty-pending-screen t))) 96 | (define (tty-cursor-column t) (screen-cursor-column (tty-pending-screen t))) 97 | 98 | (define (tty-display t . strings) 99 | (for [(str strings)] 100 | (screen-puts (tty-pending-screen t) str))) 101 | 102 | (define (tty-newline t) 103 | (define s (tty-pending-screen t)) 104 | (screen-clear-to-eol s) 105 | (screen-putc s #\return) 106 | (screen-putc s #\newline)) 107 | 108 | (define (tty-clear t) 109 | (define s (tty-pending-screen t)) 110 | (set-tty-pending-screen! t (make-screen (screen-rows s) (screen-columns s) (screen-pen s))) 111 | t) 112 | 113 | (define (tty-clear-to-eol t) (screen-clear-to-eol (tty-pending-screen t))) 114 | (define (tty-goto t row col) (screen-goto (tty-pending-screen t) row col)) 115 | (define (tty-set-pen! t p) (set-screen-pen! (tty-pending-screen t) p)) 116 | (define (tty-pen t) (screen-pen (tty-pending-screen t))) 117 | 118 | (define tty-default-pen 'default) 119 | 120 | (struct pen (foreground-color ;; Color 121 | background-color ;; Color 122 | bold? ;; Boolean 123 | italic? ;; Boolean 124 | ) #:prefab) 125 | 126 | (struct backend (name ;; Symbol 127 | priority ;; Integer 128 | factory ;; (-> TTY) 129 | ) 130 | #:prefab) 131 | 132 | (struct screen (rows ;; Nat 133 | columns ;; Nat 134 | [cursor-row #:mutable] ;; Nat 135 | [cursor-column #:mutable] ;; Nat 136 | [pen #:mutable] ;; Pen 137 | contents ;; (Vector[rows] (Vector[columns] (Cons Pen Character))) 138 | ) #:prefab) 139 | 140 | (define (screen-last-row s) (- (screen-rows s) 1)) 141 | (define (screen-last-column s) (- (screen-columns s) 1)) 142 | 143 | (define (make-screen rows columns pen) 144 | (define contents (for/vector ((row rows)) (make-vector columns (cons pen 'empty)))) 145 | (screen rows columns 0 0 pen contents)) 146 | 147 | (define (copy-screen s) 148 | (match-define (screen rows columns cursor-row cursor-column pen contents) s) 149 | (define new-contents (for/vector ((row rows)) (vector-copy (vector-ref contents row)))) 150 | (screen rows columns cursor-row cursor-column pen new-contents)) 151 | 152 | (define (screen-goto s row0 column0) 153 | (define row (max 0 (min (screen-last-row s) row0))) 154 | (define column (max 0 (min (screen-last-column s) column0))) 155 | (set-screen-cursor-row! s row) 156 | (set-screen-cursor-column! s column) 157 | s) 158 | 159 | (define (non-empty? ch) (not (equal? ch 'empty))) 160 | 161 | (define (screen-putc s ch) 162 | (match ch 163 | [#\return 164 | (screen-goto s (screen-cursor-row s) 0)] 165 | [#\newline 166 | (screen-goto s (+ (screen-cursor-row s) 1) (screen-cursor-column s))] 167 | [#\tab 168 | (for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (screen-putc s #\space))] 169 | [(and (? non-empty?) (? char-iso-control?)) 170 | (screen-puts s (format "[~x]" (char->integer ch)))] 171 | [_ 172 | (when (< (screen-cursor-column s) (screen-columns s)) 173 | (vector-set! (vector-ref (screen-contents s) (screen-cursor-row s)) 174 | (screen-cursor-column s) 175 | (cons (screen-pen s) ch))) 176 | (set-screen-cursor-column! s (+ (screen-cursor-column s) 1))])) 177 | 178 | (define (screen-puts s str) 179 | (for ((ch str)) (screen-putc s ch))) 180 | 181 | (define (screen-clear-to-eol s) 182 | (define start-column (screen-cursor-column s)) 183 | (define pen (screen-pen s)) 184 | (set-screen-pen! s tty-default-pen) 185 | (for ((i (max 0 (- (screen-columns s) (screen-cursor-column s))))) 186 | (screen-putc s 'empty)) 187 | (set-screen-pen! s pen) 188 | (screen-goto s (screen-cursor-row s) start-column) 189 | s) 190 | 191 | (define *tty-backends* '()) 192 | 193 | (define (register-tty-backend! name factory #:priority [priority 0]) 194 | (set! *tty-backends* (cons (backend name priority factory) 195 | (filter (lambda (b) (not (eq? (backend-name b) name))) 196 | *tty-backends*))) 197 | (set! *tty-backends* (sort *tty-backends* > #:key backend-priority))) 198 | 199 | (define *default-tty* #f) 200 | (define (default-tty) 201 | (when (not *default-tty*) 202 | (let loop ((backends *tty-backends*)) 203 | (match backends 204 | ['() (error 'default-tty "No available tty backends")] 205 | [(cons (backend name _priority factory) rest) 206 | (define t (factory)) 207 | (if t 208 | (set! *default-tty* t) 209 | (loop rest))]))) 210 | *default-tty*) 211 | -------------------------------------------------------------------------------- /rmacs/editor.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (except-out (struct-out editor) editor) 4 | make-editor 5 | configure-fresh-buffer! 6 | find-buffer 7 | window-layout 8 | open-window 9 | close-other-windows 10 | close-window 11 | resize-window 12 | select-window 13 | windows-for-buffer 14 | window-for-buffer 15 | visit-file! 16 | render-editor! 17 | editor-next-window 18 | editor-prev-window 19 | editor-command 20 | invoke/history 21 | collect-args-and-invoke/history 22 | editor-last-command? 23 | editor-active-buffer 24 | editor-active-modeset 25 | cmd:unbound-key-sequence 26 | editor-mainloop 27 | editor-request-shutdown! 28 | editor-force-redisplay! 29 | editor-sit-for 30 | set-editor-event! 31 | set-editor-timeout! 32 | clear-editor-event! 33 | clear-message 34 | message 35 | start-recursive-edit 36 | abandon-recursive-edit 37 | define-editor-local) 38 | 39 | (require racket/match) 40 | 41 | (require "buffer.rkt") 42 | (require "display.rkt") 43 | (require "display-terminal.rkt") 44 | (require "display-gui-check.rkt") 45 | (require "window.rkt") 46 | (require "render.rkt") 47 | (require "mode.rkt") 48 | (require "keys.rkt") 49 | (require "rope.rkt") 50 | (require "circular-list.rkt") 51 | (require "file.rkt") 52 | (require "local.rkt") 53 | (require "colorize.rkt") 54 | 55 | (struct editor (buffers ;; BufferGroup 56 | [tty #:mutable] ;; Tty 57 | [windows #:mutable] ;; (CircularList (List Window SizeSpec)), abstract window layout 58 | [active-window #:mutable] ;; (Option Window) 59 | [running? #:mutable] ;; Boolean 60 | [default-modeset #:mutable] ;; ModeSet 61 | [layout #:mutable] ;; (Option (List Layout)) 62 | [last-command #:mutable] ;; (Option Command) 63 | echo-area ;; Buffer 64 | mini-window ;; Window 65 | [active-events #:mutable] ;; (Hash Any Evt) 66 | [recursive-edit #:mutable] ;; (Option Buffer) 67 | [locals #:mutable] ;; LocalsTable 68 | ) #:prefab) 69 | 70 | (define (make-editor #:tty [tty (default-tty)] 71 | #:default-modeset [default-modeset (make-modeset)]) 72 | (define g (make-buffergroup)) 73 | (define scratch (make-buffer g "*scratch*" 74 | #:initial-contents ";; This is the scratch buffer.\n\n")) 75 | (define echo-area (make-buffer #f "*echo-area*")) 76 | (define w (make-window scratch)) 77 | (define ws (list->circular-list (list (list w (relative-size 1))))) 78 | (define miniwin (make-window echo-area)) 79 | (define e (editor g ;; buffers 80 | tty ;; tty 81 | ws ;; windows 82 | w ;; active-window 83 | #f ;; running? 84 | default-modeset ;; default-modeset 85 | #f ;; layout 86 | #f ;; last-command 87 | echo-area ;; echo-area 88 | miniwin ;; mini-window 89 | (hash) ;; active-events 90 | #f ;; recursive-edit 91 | (make-locals) ;; locals 92 | )) 93 | (initialize-buffergroup! g e) 94 | (configure-fresh-buffer! e scratch) 95 | (window-move-to! w (buffer-size scratch)) 96 | (set-window-status-line?! miniwin #f) 97 | e) 98 | 99 | (define (colorize! editor buf) 100 | (local-require "timing.rkt") 101 | (when (time* (list 'colorizing (buffer-title buf)) (colorize-burst buf)) 102 | (set-editor-event! editor 103 | colorize! 104 | (handle-evt always-evt 105 | (lambda (_) 106 | (clear-editor-event! editor colorize!) 107 | (colorize! editor buf) 108 | #t))))) 109 | 110 | (define (configure-fresh-buffer! editor buffer) 111 | (buffer-apply-modeset! buffer (editor-default-modeset editor)) 112 | (colorize! editor buffer) 113 | buffer) 114 | 115 | (define (find-buffer editor [title0 #f] #:initial-contents [initial-contents ""]) 116 | (define g (editor-buffers editor)) 117 | (define title (or title0 (unused-buffer-title g '()))) 118 | (or (lookup-buffer g title) 119 | (configure-fresh-buffer! editor (make-buffer g title #:initial-contents initial-contents)))) 120 | 121 | (define (split-size s) 122 | (match s 123 | [(absolute-size _) (relative-size 1)] ;; can't scale fixed-size windows 124 | [(relative-size w) (relative-size (/ w 2))])) 125 | 126 | (define (merge-sizes surviving disappearing) 127 | (match* (surviving disappearing) 128 | [((relative-size a) (relative-size b)) (relative-size (+ a b))] 129 | [(_ _) surviving])) 130 | 131 | (define (windows-for-buffer editor buffer) 132 | (map car (filter (lambda (e) (eq? (window-buffer (car e)) buffer)) 133 | (circular-list->list (editor-windows editor))))) 134 | 135 | (define (window-for-buffer editor buffer) 136 | (define ws (windows-for-buffer editor buffer)) 137 | (and (pair? ws) (car ws))) 138 | 139 | (define (entry-for? window) (lambda (e) (eq? (car e) window))) 140 | 141 | (define (invalidate-layout! editor) 142 | (set-editor-layout! editor #f)) 143 | 144 | (define (layout! editor) 145 | (when (not (editor-layout editor)) 146 | (set-editor-layout! editor (layout-windows (circular-list->list (editor-windows editor)) 147 | (editor-mini-window editor) 148 | (tty-columns (editor-tty editor)) 149 | (tty-rows (editor-tty editor))))) 150 | (editor-layout editor)) 151 | 152 | (define (window-layout editor win) 153 | (cond [(memf (lambda (l) (eq? (layout-window l) win)) (layout! editor)) => car] 154 | [else #f])) 155 | 156 | (define ((-layout-accessor- getter) editor window) 157 | (cond [(window-layout editor window) => getter] 158 | [else #f])) 159 | 160 | (define window-size-spec (-layout-accessor- layout-size-spec)) 161 | 162 | (define (update-window-entry editor win updater) 163 | (set-editor-windows! editor (circular-list-replacef (editor-windows editor) 164 | (entry-for? win) 165 | updater)) 166 | (invalidate-layout! editor)) 167 | 168 | (define (open-window editor buffer 169 | #:after-window [after-window (editor-active-window editor)] 170 | #:proportional? [proportional? #f] 171 | #:activate? [activate? #t]) 172 | (define existing-w (window-for-buffer editor buffer)) 173 | (define existing-size (window-size-spec editor after-window)) 174 | (define new-size (if proportional? existing-size (split-size existing-size))) 175 | (define new-point (or (and existing-w (buffer-mark-pos* buffer (window-point existing-w))) 0)) 176 | (define new-window (make-window buffer #:point new-point)) 177 | (update-window-entry editor after-window 178 | (lambda (e) (list (list after-window new-size) 179 | (list new-window new-size)))) 180 | (when activate? (set-editor-active-window! editor new-window)) 181 | new-window) 182 | 183 | (define (close-other-windows editor win) 184 | (for ((entry (circular-list->list (editor-windows editor))) #:when (not (eq? (car entry) win))) 185 | (set-window-buffer! (car entry) #f)) 186 | (set-editor-windows! editor (list->circular-list (list (list win (relative-size 1))))) 187 | (set-editor-active-window! editor win) 188 | (invalidate-layout! editor)) 189 | 190 | (define (close-window editor win) 191 | (define prev (editor-prev-window editor win)) 192 | (define prev-size (window-size-spec editor prev)) 193 | (define win-size (window-size-spec editor win)) 194 | (when (and prev (> (circular-length (editor-windows editor)) 1)) 195 | (when (eq? (editor-active-window editor) win) (set-editor-active-window! editor prev)) 196 | (update-window-entry editor win (lambda (e) '())) 197 | (resize-window editor prev (merge-sizes prev-size win-size)))) 198 | 199 | (define (resize-window editor win size) 200 | (update-window-entry editor win (lambda (e) (list (list win size))))) 201 | 202 | (define (select-window editor win) 203 | (when (window-layout editor win) 204 | (set-editor-active-window! editor win))) 205 | 206 | (define (visit-file! editor filename) 207 | (set-window-buffer! (editor-active-window editor) 208 | (configure-fresh-buffer! editor 209 | (load-buffer (editor-buffers editor) 210 | (local-file-buffer-source filename))))) 211 | 212 | (define (render-editor! editor) 213 | (render-windows! (editor-tty editor) 214 | (layout! editor) 215 | (editor-active-window editor))) 216 | 217 | (define (editor-active-buffer editor) 218 | (define w (editor-active-window editor)) 219 | (and w (window-buffer w))) 220 | 221 | (define (editor-active-modeset editor) 222 | (let* ((b (editor-active-buffer editor)) 223 | (b (if (eq? b (editor-echo-area editor)) (editor-recursive-edit editor) b))) 224 | (and b (buffer-modeset b)))) 225 | 226 | (define (editor-next-window editor win) 227 | (cond [(circular-list-memf (entry-for? win) 228 | (editor-windows editor)) => (compose car 229 | circular-car 230 | circular-list-rotate-forward)] 231 | [else #f])) 232 | 233 | (define (editor-prev-window editor win) 234 | (cond [(circular-list-memf (entry-for? win) 235 | (editor-windows editor)) => (compose car 236 | circular-car 237 | circular-list-rotate-backward)] 238 | [else #f])) 239 | 240 | (define (editor-command signature editor 241 | #:args args 242 | #:keyseq [keyseq #f] 243 | #:prefix-arg [prefix-arg '#:default]) 244 | (window-command signature (editor-active-window editor) 245 | #:args args 246 | #:editor editor 247 | #:keyseq keyseq 248 | #:prefix-arg prefix-arg)) 249 | 250 | (define ((abort-handler editor) e) 251 | (message editor "~a" (exn-message e) #:duration (exn:abort-duration e)) 252 | (void)) 253 | 254 | (define (invoke/history cmd) 255 | (define editor (command-editor cmd)) 256 | (with-handlers* ([exn:abort? (abort-handler editor)]) 257 | (let ((old-last-command (editor-last-command editor))) 258 | (define result (invoke cmd)) 259 | (when (eq? (editor-last-command editor) old-last-command) 260 | (set-editor-last-command! editor cmd)) 261 | result))) 262 | 263 | (define (collect-args-and-invoke/history editor sig keyseq prefix-arg) 264 | (with-handlers* ([exn:abort? (abort-handler editor)]) 265 | (collect-args sig editor (lambda (args) 266 | (invoke/history (editor-command sig editor 267 | #:args args 268 | #:keyseq keyseq 269 | #:prefix-arg prefix-arg)))))) 270 | 271 | (define (editor-last-command? editor . possible-signatures) 272 | (and (editor-last-command editor) 273 | (for/or ((signature (in-list possible-signatures))) 274 | (equal? (command-command-signature (editor-last-command editor)) signature)))) 275 | 276 | (define (root-keyseq-handler editor) 277 | (modeset-keyseq-handler (editor-active-modeset editor))) 278 | 279 | (define *error-count* 0) 280 | (define (open-debugger editor exc) 281 | (define error-report 282 | (if (exn? exc) 283 | (parameterize ([current-error-port (open-output-string)]) 284 | ((error-display-handler) (exn-message exc) exc) 285 | (get-output-string (current-error-port))) 286 | (format "~v" exc))) 287 | (log-error "Exception:\n~a\n" error-report) 288 | (set! *error-count* (+ *error-count* 1)) 289 | (when (>= *error-count* 3) (exit)) 290 | (define b (find-buffer editor "*Error*")) 291 | (buffer-replace-contents! b (piece->rope error-report)) 292 | (open-window editor b)) 293 | 294 | (define-simple-command-signature (unbound-key-sequence) #:category event) 295 | 296 | (define (editor-background-events editor result-handler) 297 | (apply choice-evt 298 | (for/list [(e (in-hash-values (editor-active-events editor)))] 299 | (handle-evt e result-handler)))) 300 | 301 | (define (editor-mainloop editor) 302 | (when (editor-running? editor) (error 'editor-mainloop "Nested mainloop")) 303 | (set-editor-running?! editor #t) 304 | (with-handlers* ([exn? (lambda (exc) 305 | (set-editor-running?! editor #f) 306 | (open-debugger editor exc) 307 | (editor-mainloop editor))]) 308 | (let loop ((total-keyseq '()) 309 | (input '()) 310 | (handler (root-keyseq-handler editor)) 311 | (next-repaint-deadline 0)) 312 | (define (request-repaint) (or next-repaint-deadline (+ (current-inexact-milliseconds) 20))) 313 | (define (wait-for-input next-handler) 314 | (when (editor-running? editor) 315 | (sync (if next-repaint-deadline 316 | (handle-evt (alarm-evt next-repaint-deadline) 317 | (lambda (_) 318 | (loop total-keyseq '() next-handler next-repaint-deadline))) 319 | never-evt) 320 | (editor-background-events editor 321 | (lambda (wants-repaint?) 322 | (loop total-keyseq 323 | '() 324 | next-handler 325 | (if wants-repaint? 326 | (request-repaint) 327 | next-repaint-deadline)))) 328 | (handle-evt (tty-next-key-evt (editor-tty editor)) 329 | (lambda (new-key) 330 | (cond [(not new-key) (wait-for-input next-handler)] 331 | [else (define new-input (list new-key)) 332 | (clear-message editor) 333 | (loop (append total-keyseq new-input) 334 | new-input 335 | next-handler 336 | next-repaint-deadline)])))))) 337 | (cond 338 | [(and next-repaint-deadline (>= (current-inexact-milliseconds) next-repaint-deadline)) 339 | (render-editor! editor) 340 | (loop total-keyseq input handler #f)] 341 | [(null? input) 342 | (wait-for-input handler)] 343 | [else 344 | (match (handler editor input) 345 | [(unbound-key-sequence) 346 | (when (not (invoke/history (editor-command cmd:unbound-key-sequence 347 | editor 348 | #:args '() 349 | #:keyseq total-keyseq))) 350 | (message editor "Unbound key sequence: ~a" (keyseq->keyspec total-keyseq))) 351 | (loop '() '() (root-keyseq-handler editor) (request-repaint))] 352 | [(incomplete-key-sequence next-handler) 353 | (message #:log? #f editor "~a-" (keyseq->keyspec total-keyseq)) 354 | (wait-for-input next-handler)] 355 | [(command-invocation sig prefix-arg remaining-input) 356 | (define accepted-input 357 | (let remove-tail ((keyseq total-keyseq)) 358 | (if (equal? keyseq remaining-input) 359 | '() 360 | (cons (car keyseq) (remove-tail (cdr keyseq)))))) 361 | (collect-args-and-invoke/history editor sig accepted-input prefix-arg) 362 | (loop '() remaining-input (root-keyseq-handler editor) (request-repaint))])])))) 363 | 364 | (define (editor-request-shutdown! editor) 365 | (set-editor-running?! editor #f)) 366 | 367 | (define (editor-force-redisplay! editor) 368 | (tty-reset (editor-tty editor)) 369 | (invalidate-layout! editor)) 370 | 371 | ;; Answers #t if it waited the full length of time. 372 | (define (editor-sit-for editor seconds) 373 | (define deadline (+ (current-inexact-milliseconds) (* seconds 1000.0))) 374 | 375 | ;; It is safe to use e (which includes tty-input-available-evt) more 376 | ;; than once but ONLY because we do not actually read any input from 377 | ;; the tty between uses. 378 | (define e (choice-evt (tty-input-available-evt (editor-tty editor)) 379 | (editor-background-events 380 | editor 381 | (lambda (wants-repaint?) ;; repainting handled by loop structure 382 | 'recheck)))) 383 | 384 | (define input-available? 385 | (let recheck () 386 | (match (sync/timeout 0 e) 387 | [#f 388 | (render-editor! editor) 389 | (define remaining (max 0 (/ (- deadline (current-inexact-milliseconds)) 1000.0))) 390 | (match (sync/timeout remaining e) 391 | [#f #f] 392 | [#t #t] 393 | ['recheck (recheck)])] 394 | [#t #t] 395 | ['recheck (recheck)]))) 396 | (not input-available?)) 397 | 398 | (define (set-editor-event! editor key e) 399 | (set-editor-active-events! editor (hash-set (editor-active-events editor) key e))) 400 | 401 | (define (clear-editor-event! editor key) 402 | (set-editor-active-events! editor (hash-remove (editor-active-events editor) key))) 403 | 404 | (define (set-editor-timeout! editor key delay-ms thunk 405 | #:wants-repaint? [wants-repaint? #t]) 406 | (set-editor-event! editor key 407 | (handle-evt (alarm-evt (+ (current-inexact-milliseconds) delay-ms)) 408 | (lambda (_) (thunk) wants-repaint?)))) 409 | 410 | (define (clear-message editor) 411 | (when (positive? (buffer-size (editor-echo-area editor))) 412 | (buffer-replace-contents! (editor-echo-area editor) (rope-empty)) 413 | (define re (editor-recursive-edit editor)) 414 | (when (and re (not (eq? (window-buffer (editor-mini-window editor)) re))) 415 | (set-window-buffer! (editor-mini-window editor) re (buffer-size re))) 416 | (clear-editor-event! editor clear-message) 417 | (invalidate-layout! editor))) 418 | 419 | (define (message #:duration [duration0 #f] 420 | #:log? [log? #t] 421 | editor fmt . args) 422 | (define duration (or duration0 (and (editor-recursive-edit editor) 2))) 423 | (define msg (piece->rope (apply format fmt args))) 424 | (define echo-area (editor-echo-area editor)) 425 | (when log? 426 | (let* ((msgbuf (find-buffer editor "*Messages*")) 427 | (msgwins (filter (lambda (w) (equal? (buffer-mark-pos msgbuf (window-point w)) 428 | (buffer-size msgbuf))) 429 | (windows-for-buffer editor msgbuf)))) 430 | (buffer-insert! msgbuf (buffer-size msgbuf) (rope-append msg (piece->rope "\n"))) 431 | (for ((w msgwins)) (buffer-mark! msgbuf (window-point w) (buffer-size msgbuf))))) 432 | (buffer-replace-contents! echo-area msg) 433 | (set-window-buffer! (editor-mini-window editor) echo-area (buffer-size echo-area)) 434 | (invalidate-layout! editor) 435 | (when duration 436 | (set-editor-timeout! editor clear-message (* duration 1000.0) 437 | (lambda () (clear-message editor)))) 438 | (render-editor! editor)) 439 | 440 | (define (start-recursive-edit editor buf) 441 | (when (editor-recursive-edit editor) 442 | (abort "Command attempted to use minibuffer while in minibuffer")) 443 | (set-editor-recursive-edit! editor buf) 444 | (define miniwin (editor-mini-window editor)) 445 | (set-window-buffer! miniwin buf (buffer-size buf)) 446 | (set-editor-windows! editor 447 | (circular-snoc (editor-windows editor) 448 | (list miniwin (absolute-size 0)))) 449 | (set-editor-active-window! editor miniwin) 450 | (invalidate-layout! editor)) 451 | 452 | (define (abandon-recursive-edit editor) 453 | (set-editor-recursive-edit! editor #f) 454 | (define echo-area (editor-echo-area editor)) 455 | (define miniwin (editor-mini-window editor)) 456 | (set-window-buffer! miniwin echo-area (buffer-size echo-area)) 457 | (when (eq? (editor-active-window editor) miniwin) 458 | (set-editor-active-window! editor (car (circular-car (editor-windows editor))))) 459 | (update-window-entry editor miniwin (lambda (e) '())) 460 | (invalidate-layout! editor)) 461 | 462 | (define-local-definer define-editor-local editor-locals set-editor-locals!) 463 | 464 | ;;--------------------------------------------------------------------------- 465 | 466 | (define-simple-command-signature (save-buffers-kill-terminal)) 467 | (define-simple-command-signature (force-redisplay)) 468 | (define-simple-command-signature (keyboard-quit)) 469 | (define-simple-command-signature (dump-buffer-to-stderr)) 470 | (define-simple-command-signature (version)) 471 | 472 | (define-command kernel-mode cmd:save-buffers-kill-terminal (#:editor ed) 473 | #:bind-key "C-x C-c" 474 | (editor-request-shutdown! ed)) 475 | 476 | (define-command kernel-mode cmd:force-redisplay (#:editor ed) 477 | #:bind-key "C-l" 478 | #:bind-key "" 479 | (editor-force-redisplay! ed)) 480 | 481 | (define-command kernel-mode cmd:keyboard-quit () 482 | #:bind-key "C-g" 483 | (abort "Quit")) 484 | 485 | (define-command kernel-mode cmd:dump-buffer-to-stderr (#:buffer buf #:window win #:editor ed) 486 | #:bind-key "C-M-x" 487 | (local-require racket/pretty) 488 | (log-info "") 489 | (log-info "--------------------------------------------------------------------------------") 490 | (log-info "--------------------------------------------------------------------------------") 491 | (log-info "========================================================================= WINDOW") 492 | (log-info "id ~v" (window-id win)) 493 | (log-info "top ~v ~v" (window-top win) (buffer-mark-pos* buf (window-top win))) 494 | (log-info "point ~v ~v" (window-point win) (buffer-mark-pos* buf (window-point win))) 495 | (log-info "mark ~v" (buffer-mark-pos* buf region-mark)) 496 | (log-info "title ~v" (buffer-title buf)) 497 | (log-info "locals:") 498 | (for (((k v) (in-hash (buffer-locals buf)))) (log-info" - ~a: ~v" k v)) 499 | (log-info "rope:") 500 | (pretty-write (buffer-rope buf) (current-error-port)) 501 | (log-info "modeset:") 502 | (pretty-write (buffer-modeset buf) (current-error-port)) 503 | (let ((t (editor-tty ed))) 504 | (log-info "terminal width ~v height ~v cursor-row ~v -col ~v" 505 | (tty-columns t) (tty-rows t) (tty-cursor-row t) (tty-cursor-column t))) 506 | (log-info "editor layout:") 507 | (cond [(editor-layout ed) => 508 | (lambda (layouts) 509 | (for ((l layouts)) 510 | (match-define (layout w s tt ll) l) 511 | (log-info " - ~a ~v top ~a left ~a width ~a height ~a" 512 | (window-id w) s tt ll (window-width w) (window-height w))))] 513 | [else (log-info " - not cached")]) 514 | (log-info "editor size-specs: ~v" 515 | (for/list ((e (circular-list->list (editor-windows ed)))) 516 | (list (window-id (car e)) (cadr e)))) 517 | (log-info "--------------------------------------------------------------------------------")) 518 | 519 | (define-command kernel-mode cmd:version (#:window win) 520 | (collect-garbage) 521 | (message (window-editor win) 522 | (format "Racket version ~a; memory usage ~a bytes" 523 | (version) 524 | (current-memory-use)))) 525 | -------------------------------------------------------------------------------- /rmacs/file.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide gen:buffer-source 4 | buffer-source-path 5 | buffer-source-title-pieces 6 | buffer-source-mtime 7 | buffer-source-read 8 | buffer-source-write 9 | 10 | (struct-out local-file-buffer-source)) 11 | 12 | (require racket/generic) 13 | (require (only-in racket/file file->string)) 14 | (require (only-in racket/path normalize-path)) 15 | 16 | (define-generics buffer-source 17 | (buffer-source-path buffer-source) 18 | (buffer-source-title-pieces buffer-source) 19 | (buffer-source-mtime buffer-source) 20 | (buffer-source-read buffer-source) 21 | (buffer-source-write buffer-source content)) 22 | 23 | (struct local-file-buffer-source (filename) 24 | #:transparent 25 | #:methods gen:buffer-source 26 | [(define (buffer-source-path src) 27 | (normalize-path (simplify-path (local-file-buffer-source-filename src)))) 28 | (define (buffer-source-title-pieces src) 29 | (reverse (map path->string (explode-path (buffer-source-path src))))) 30 | (define (buffer-source-mtime src) 31 | (file-or-directory-modify-seconds (buffer-source-path src))) 32 | (define (buffer-source-read src) 33 | (define p (buffer-source-path src)) 34 | (if (and p (file-exists? p)) (file->string p) "")) 35 | (define (buffer-source-write src content) 36 | (call-with-output-file (buffer-source-path src) 37 | (lambda (p) (write-string content p)) 38 | #:exists 'replace)) 39 | ]) 40 | -------------------------------------------------------------------------------- /rmacs/history.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (struct-out history) 4 | make-history 5 | history-length 6 | history-ref 7 | history-push! 8 | ) 9 | 10 | (require (only-in racket/list take)) 11 | 12 | ;; A History is a (history (List String) (Option Nat) Boolean). 13 | (struct history ([items #:mutable] 14 | max-count 15 | delete-duplicates? 16 | ) #:prefab) 17 | 18 | (define (make-history [items '()] 19 | #:max-count [max-count 30] 20 | #:delete-duplicates? [delete-duplicates? #f]) 21 | (history items max-count delete-duplicates?)) 22 | 23 | (define (history-length h) 24 | (length (history-items h))) 25 | 26 | (define (history-ref h index) 27 | (and (>= index 0) 28 | (< index (history-length h)) 29 | (list-ref (history-items h) index))) 30 | 31 | (define (history-push! h item) 32 | (define new-items 33 | (cons item (if (history-delete-duplicates? h) 34 | (filter (lambda (x) (not (equal? x item))) (history-items h)) 35 | (history-items h)))) 36 | (define limit (history-max-count h)) 37 | (set-history-items! h (if (> (length new-items) limit) 38 | (take new-items limit) 39 | new-items))) 40 | -------------------------------------------------------------------------------- /rmacs/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define name "editor") 4 | (define blurb 5 | (list 6 | `(p "Emacs-like editor."))) 7 | (define homepage "https://github.com/tonyg/racket-ansi") 8 | (define primary-file "main.rkt") 9 | 10 | (define racket-launcher-names '("rmacs")) 11 | (define racket-launcher-libraries '("main.rkt")) 12 | -------------------------------------------------------------------------------- /rmacs/keys.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Keyspecs, keyseqs and keymaps 3 | 4 | (provide parse-key-sequence 5 | keyspec->keyseq 6 | key->keyspec 7 | keyseq->keyspec 8 | (struct-out keymap) 9 | empty-keymap 10 | keymap-update 11 | keymap-bind 12 | keymap-unbind 13 | keymap-lookup 14 | 15 | ;; From ansi/lcd-terminal 16 | (struct-out key) 17 | (struct-out unknown-escape-sequence) 18 | add-modifier) 19 | 20 | (require racket/set) 21 | (require racket/match) 22 | (require (only-in racket/list append-map)) 23 | (require (only-in racket/string 24 | string-join 25 | string-split 26 | string-trim)) 27 | 28 | (require ansi/lcd-terminal) 29 | 30 | ;;--------------------------------------------------------------------------- 31 | ;; Key sequence parsing 32 | 33 | (define (read-string-to-end s) 34 | (define p (open-input-string s)) 35 | (define result (read p)) 36 | (and (eof-object? (peek-char p)) 37 | result)) 38 | 39 | (define (bad-key lexeme fmt . args) 40 | (error 'parse-key-sequence "~a in key ~v" (apply format fmt args) (string-trim lexeme))) 41 | 42 | (define (parse-modifiers modifiers lexeme) 43 | (for/set ((mod (string-split (string-upcase modifiers) "-"))) 44 | (match mod 45 | ["C" 'control] 46 | ["S" 'shift] 47 | ["M" 'meta] 48 | [_ (bad-key lexeme "Unknown modifier ~a" mod)]))) 49 | 50 | (define (parse-key-sequence s) 51 | (match s 52 | [(pregexp "^ *#:default(( +.*)|$)" (list lexeme rest _)) 53 | (cons '#:default (parse-key-sequence rest))] 54 | [(pregexp "^ *(([cCsSmM]-)*)\"([^\"]*)\"(.*)" (list lexeme modifiers _ stringspec rest)) 55 | (define mods (parse-modifiers modifiers lexeme)) 56 | (define seq (unknown-escape-sequence (or (read-string-to-end (format "#\"~a\"" stringspec)) 57 | (bad-key lexeme "Bad raw input sequence")))) 58 | (cons (key seq mods) (parse-key-sequence rest))] 59 | [(pregexp "^ *(([cCsSmM]-)*)<([^>]+)>(( +.*)|$)" (list lexeme modifiers _ symname rest _)) 60 | (define mods (parse-modifiers modifiers lexeme)) 61 | (cons (key (string->symbol symname) mods) 62 | (parse-key-sequence rest))] 63 | [(pregexp "^ *(([cCsSmM]-)*)([^ ]+)(( +.*)|$)" (list lexeme modifiers _ keystr rest _)) 64 | (define mods (parse-modifiers modifiers lexeme)) 65 | (define keychar (or (read-string-to-end (format "#\\~a" keystr)) 66 | (bad-key lexeme "Bad single-character key"))) 67 | (cons (key (if (set-member? mods 'control) 68 | (char-upcase keychar) 69 | keychar) 70 | mods) 71 | (parse-key-sequence rest))] 72 | [(pregexp "^ *$") 73 | '()] 74 | [_ (bad-key s "Unexpected junk")])) 75 | 76 | (define (keyspec->keyseq what original-keyspec) 77 | (let convert ((keyspec original-keyspec)) 78 | (cond 79 | [(key? keyspec) (list keyspec)] 80 | [(keyword? keyspec) (list keyspec)] 81 | [(string? keyspec) (parse-key-sequence keyspec)] 82 | [(list? keyspec) (append-map convert keyspec)] 83 | [else (error what "Invalid key specification: ~v" original-keyspec)]))) 84 | 85 | (define (format-modifiers mods suffix) 86 | (if (set-empty? mods) 87 | suffix 88 | (string-append (string-join (map (lambda (m) 89 | (match m 90 | ['control "C"] 91 | ['shift "S"] 92 | ['meta "M"])) 93 | (set->list mods)) 94 | "-") 95 | "-" 96 | suffix))) 97 | 98 | (define (key->keyspec k) 99 | (match k 100 | [(? keyword?) (format "~a" k)] 101 | [(key value modifiers) 102 | (define-values (str updated-modifiers) 103 | (match value 104 | [(unknown-escape-sequence bs) 105 | (define s (format "~v" bs)) 106 | (values (substring s 1 (string-length s)) modifiers)] 107 | [(? symbol? s) 108 | (values (format "<~a>" s) modifiers)] 109 | [(? char? c) 110 | (define s (format "~v" c)) 111 | (define maybe-downcase (if (set-member? modifiers 'control) string-downcase values)) 112 | (values (maybe-downcase (substring s 2 (string-length s))) modifiers)])) 113 | (format-modifiers updated-modifiers str)])) 114 | 115 | (define (keyseq->keyspec keyseq) 116 | (and keyseq (string-join (map key->keyspec keyseq) " "))) 117 | 118 | ;;--------------------------------------------------------------------------- 119 | ;; Keymaps 120 | 121 | (struct keymap (table 122 | ) #:prefab) 123 | 124 | (define (empty-keymap) 125 | (keymap (hash))) 126 | 127 | (define (keymap-update km keyspec updater) 128 | (define original-keyseq (keyspec->keyseq 'keymap-bind keyspec)) 129 | (let loop ((prefix-rev '()) 130 | (keyseq original-keyseq) 131 | (km km)) 132 | (match keyseq 133 | ['() (updater (reverse prefix-rev) km original-keyseq)] 134 | [(cons k rest) 135 | (cond 136 | [(keymap? km) 137 | (let* ((new (loop (cons k prefix-rev) rest (hash-ref (keymap-table km) k #f))) 138 | (newtab (if new 139 | (hash-set (keymap-table km) k new) 140 | (hash-remove (keymap-table km) k)))) 141 | (if (hash-empty? newtab) 142 | #f 143 | (struct-copy keymap km [table newtab])))] 144 | [(not km) 145 | (loop prefix-rev keyseq (empty-keymap))] 146 | [else 147 | (error 'keymap-update 148 | "Cannot update keyspec ~v, as a shorter prefix ~v exists" 149 | (keyseq->keyspec original-keyseq) 150 | (keyseq->keyspec (reverse prefix-rev)))])]))) 151 | 152 | (define (keymap-bind km keyspec command) 153 | (keymap-update km keyspec (lambda (prefix oldval newseq) 154 | (if oldval 155 | (error 'keymap-bind "Cannot bind ~v, as prefix ~v exists" 156 | (keyseq->keyspec newseq) 157 | (keyseq->keyspec prefix)) 158 | command)))) 159 | 160 | (define (keymap-bind* km specs-and-commands) 161 | (match specs-and-commands 162 | ['() km] 163 | [(cons (list keyspec command) rest) (keymap-bind* (keymap-bind km keyspec command) rest)])) 164 | 165 | (define (keymap-unbind km keyspec) 166 | (or (keymap-update km keyspec (lambda (prefix oldval newseq) #f)) 167 | (empty-keymap))) 168 | 169 | (define (keymap-lookup km keyspec) 170 | (define original-keyseq (keyspec->keyseq 'keymap-lookup keyspec)) 171 | (let loop ((keyseq original-keyseq) 172 | (km km)) 173 | (match keyseq 174 | ['() (values km keyseq)] 175 | [(cons k rest) 176 | (match km 177 | [(keymap table) (loop rest (or (hash-ref table k #f) 178 | (hash-ref table '#:default #f)))] 179 | [_ (values km keyseq)])]))) 180 | 181 | ;;--------------------------------------------------------------------------- 182 | 183 | (module+ test 184 | (require rackunit racket/pretty) 185 | 186 | (check-equal? (parse-key-sequence "<") (list (key #\< (set)))) 187 | (check-equal? (parse-key-sequence ">") (list (key #\> (set)))) 188 | (check-equal? (parse-key-sequence "#:default #:default") 189 | (list '#:default '#:default)) 190 | 191 | (define km (keymap-bind* (empty-keymap) (list (list "C-x o" 'other-window) 192 | (list "C-x 2" 'split-window) 193 | (list "C-x 1" 'delete-other-windows) 194 | (list "C-x 0" 'delete-window)))) 195 | (check-equal? km 196 | (keymap (hash (key #\X (set 'control)) 197 | (keymap (hash (key #\o (set)) 'other-window 198 | (key #\2 (set)) 'split-window 199 | (key #\1 (set)) 'delete-other-windows 200 | (key #\0 (set)) 'delete-window))))) 201 | (set! km (keymap-unbind km "C-x 1")) 202 | (check-equal? km 203 | (keymap (hash (key #\X (set 'control)) 204 | (keymap (hash (key #\o (set)) 'other-window 205 | (key #\2 (set)) 'split-window 206 | (key #\0 (set)) 'delete-window))))) 207 | (check-equal? (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0") 208 | (keymap (hash (key #\X (set 'control)) 209 | (keymap (hash (key #\o (set)) 'other-window))))) 210 | (check-equal? (keymap-unbind (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0") "C-x o") 211 | (empty-keymap)) 212 | (check-equal? (keymap-unbind km "C-x") 213 | (empty-keymap)) 214 | 215 | (define (lookup s) 216 | (define-values (result remaining-input) (keymap-lookup km s)) 217 | (list result remaining-input)) 218 | 219 | (check-equal? (lookup "C-x") (list (keymap (hash (key #\o (set)) 'other-window 220 | (key #\2 (set)) 'split-window 221 | (key #\0 (set)) 'delete-window)) 222 | '())) 223 | (check-equal? (lookup "C-x 1") (list #f '())) 224 | (check-equal? (lookup "C-x 2") (list 'split-window '())) 225 | (check-equal? (lookup "C-c") (list #f '())) 226 | (check-equal? (lookup "C-c C-c") (list #f (list (key #\C (set 'control))))) 227 | ) 228 | -------------------------------------------------------------------------------- /rmacs/lists.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; List utilities :-( 3 | 4 | (provide replacef) 5 | 6 | (require racket/list) 7 | 8 | (define (replacef lst finder replacer) 9 | (define-values (head tail) (splitf-at lst (lambda (e) (not (finder e))))) 10 | (if (null? tail) 11 | head 12 | (append head 13 | (replacer (car tail)) 14 | (cdr tail)))) 15 | 16 | (module+ test 17 | (require rackunit) 18 | 19 | (check-equal? (replacef '(1 2 3 4 5) even? (lambda (n) (list n n n))) 20 | '(1 2 2 2 3 4 5))) 21 | -------------------------------------------------------------------------------- /rmacs/local.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide make-locals 4 | make-local 5 | define-local-definer) 6 | 7 | (require racket/match) 8 | 9 | ;; A LocalsTable is a (HashEqTable Symbol Any). 10 | 11 | (define (make-locals) (hasheq)) 12 | 13 | (define (make-local get-locals set-locals! name [default-thunk (lambda () #f)]) 14 | (case-lambda 15 | [(thing) 16 | (hash-ref (get-locals thing) name (lambda () 17 | (define val (default-thunk)) 18 | (set-locals! thing (hash-set (get-locals thing) 19 | name 20 | val)) 21 | val))] 22 | [(thing val) 23 | (match thing 24 | ['#:clear (set-locals! val (hash-remove (get-locals val) name))] 25 | [_ (set-locals! thing (hash-set (get-locals thing) name val))]) 26 | val])) 27 | 28 | (define-syntax-rule (define-local-definer definer get-locals set-locals!) 29 | (define-syntax definer 30 | (syntax-rules () 31 | ((_ name) (define name (make-local get-locals set-locals! 'name))) 32 | ((_ name default) (define name (make-local get-locals 33 | set-locals! 34 | 'name 35 | (lambda () default))))))) 36 | -------------------------------------------------------------------------------- /rmacs/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide rmacs) 4 | 5 | (require racket/match) 6 | 7 | (require "editor.rkt") 8 | (require "buffer.rkt") 9 | (require "mode.rkt") 10 | (require "mode/fundamental.rkt") 11 | 12 | (define (usable-terminal?) 13 | (not (equal? (getenv "TERM") "dumb"))) 14 | 15 | (define (rmacs #:initial-files [initial-files '()]) 16 | (define e (make-editor #:default-modeset (modeset-add-mode kernel-modeset 17 | fundamental-mode))) 18 | (for ((file initial-files)) (visit-file! e file)) 19 | (editor-mainloop e)) 20 | 21 | (module+ main 22 | (require racket/trace) 23 | (current-trace-notify (lambda (s) (log-info "TRACE: ~a" s))) 24 | (when (not (usable-terminal?)) 25 | (error 'rmacs 26 | "Cannot run with TERM=~a; terminal lacks essential features." 27 | (getenv "TERM"))) 28 | (local-require profile) 29 | (void #;profile 30 | (rmacs #:initial-files (match (current-command-line-arguments) 31 | ['#() 32 | (list 33 | (build-path (collection-file-path "main.rkt" "ansi") 34 | 'up 'up "doc" "xterm_controls.txt"))] 35 | [(vector files ...) 36 | files]))) 37 | ) 38 | -------------------------------------------------------------------------------- /rmacs/mark.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Marks and their indexes, to be used in ropes. 3 | 4 | (provide (struct-out mark-type) 5 | rope-marks 6 | clear-mark 7 | set-mark 8 | replace-mark 9 | find-all-marks/type 10 | clear-all-marks 11 | clear-all-marks/type) 12 | 13 | (require racket/set) 14 | (require racket/match) 15 | (require "rope.rkt") 16 | (require "rope/piece.rkt") 17 | (require "rope/index.rkt") 18 | 19 | ;; A MarkType is a (mark-type Any Stickiness). MarkTypes can be 20 | ;; associated with a set of Any values at each position in the rope. 21 | (struct mark-type (info stickiness) #:prefab) 22 | 23 | (struct marks-index (set) #:transparent 24 | #:methods gen:index 25 | [(define/generic rev-merge index-rev-merge) 26 | (define (index-merge i1 i2) 27 | (if (marks-index? i2) 28 | (marks-index (set-union (marks-index-set i1) (marks-index-set i2))) 29 | (rev-merge i2 i1))) 30 | (define (index-rev-merge i2 i1) 31 | (error 'index-rev-merge "Cannot rev-merge index ~v with ~v" i2 i1)) 32 | (define (index-contains? i key) 33 | (set-member? (marks-index-set i) key))]) 34 | 35 | (struct marks (table) #:transparent 36 | #:methods gen:piece 37 | [(define/generic rev-merge piece-rev-merge) 38 | (define (piece-size ms) 0) 39 | (define (piece-empty? ms) (hash-empty? (marks-table ms))) 40 | (define (piece->searchable-string ms) "") 41 | (define (piece-match ms forward? key offset) 42 | (match (hash-ref (marks-table ms) key #f) 43 | [#f '()] 44 | [value (list (cons 0 value))])) 45 | (define (piece-split ms offset) 46 | (values (marks (for/hasheq [((mtype value) (in-hash (marks-table ms))) 47 | #:when (eq? (mark-type-stickiness mtype) 'left)] 48 | (values mtype value))) 49 | (marks (for/hasheq [((mtype value) (in-hash (marks-table ms))) 50 | #:when (eq? (mark-type-stickiness mtype) 'right)] 51 | (values mtype value))))) 52 | (define (piece-merge ms1 ms2 k-merge k-no-merge) 53 | (if (marks? ms2) 54 | (k-merge (marks (for/fold [(t (marks-table ms1))] 55 | [((mtype value) (in-hash (marks-table ms2)))] 56 | (hash-set t mtype value)))) 57 | (rev-merge ms2 ms1 k-merge k-no-merge))) 58 | (define (piece-rev-merge ms2 ms1 k-merge k-no-merge) 59 | (k-no-merge)) 60 | (define (piece->index ms) 61 | (marks-index (list->seteq (hash-keys (marks-table ms)))))]) 62 | 63 | (define (rope-marks r) 64 | (define i (rope-index r)) 65 | (if i (marks-index-set i) (seteq))) 66 | 67 | (define (remove-single-mark r mtype) 68 | (define table (hash-remove (marks-table (rope-piece r)) mtype)) 69 | (update-piece r (marks table))) 70 | 71 | (define (clear-mark r0 mtype position) 72 | (define-values (l r) (rope-split r0 position)) 73 | (rope-append (if (and l (marks? (rope-piece l)) (eq? (mark-type-stickiness mtype) 'left)) 74 | (remove-single-mark l mtype) 75 | l) 76 | (if (and r (marks? (rope-piece r)) (eq? (mark-type-stickiness mtype) 'right)) 77 | (remove-single-mark r mtype) 78 | r))) 79 | 80 | (define (set-mark r0 mtype position value) 81 | (define-values (l r) (rope-split (clear-mark r0 mtype position) position)) 82 | (rope-append (rope-append l (piece->rope (marks (hasheq mtype value)))) r)) 83 | 84 | (define (replace-mark r0 mtype new-pos new-value) 85 | (define pos (find-pos-in-index r0 mtype)) 86 | (set-mark (if pos (clear-mark r0 mtype pos) r0) mtype new-pos new-value)) 87 | 88 | (define (find-all-marks/type r mtype) 89 | (find-all-in-index r mtype)) 90 | 91 | (define (clear-all-marks r) 92 | (rope-map r (lambda (p) (and (string? p) p)))) 93 | 94 | (define (clear-all-marks/type r mtype) 95 | (rope-map/key r mtype (lambda (p) (if (not (marks? p)) 96 | p 97 | (marks (hash-remove (marks-table p) mtype)))))) 98 | 99 | (module+ for-test 100 | (provide (struct-out marks) 101 | (struct-out marks-index))) 102 | -------------------------------------------------------------------------------- /rmacs/minibuf.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide minibuffer-history 4 | read-from-minibuffer 5 | string-arg 6 | read-string-from-minibuffer 7 | recursive-edit-field-start 8 | recursive-edit-mode 9 | recursive-edit-accept-hook 10 | recursive-edit-cancel-hook 11 | recursive-edit-acceptable-hook 12 | completing-read 13 | simple-completion 14 | completing-read-mode 15 | completing-read-string=?-hook 16 | completing-read-completion-hook) 17 | 18 | (require "buffer.rkt") 19 | (require "editor.rkt") 20 | (require "mode.rkt") 21 | (require "keys.rkt") 22 | (require "rope.rkt") 23 | (require "mark.rkt") 24 | (require "window.rkt") 25 | (require "strings.rkt") 26 | (require "history.rkt") 27 | 28 | ;;--------------------------------------------------------------------------- 29 | 30 | (define-editor-local minibuffer-history (make-history)) 31 | 32 | (define (read-from-minibuffer editor 33 | prompt 34 | #:history [history (minibuffer-history editor)] 35 | #:initial [initial ""] 36 | #:defaults [defaults '()] 37 | #:acceptable? [acceptable? (lambda (v) #t)] 38 | #:on-accept k-accept 39 | #:on-cancel [k-cancel void]) 40 | (define buf (make-buffer #f "*minibuf*")) 41 | (configure-fresh-buffer! editor buf) 42 | (buffer-add-mode! buf recursive-edit-mode) 43 | (buffer-replace-contents! buf (piece->rope prompt)) 44 | (buffer-mark! buf recursive-edit-field-start (buffer-size buf)) 45 | (set-recursive-edit-contents! buf initial) 46 | (recursive-edit-selected-window buf (editor-active-window editor)) 47 | (recursive-edit-history buf (or history (make-history))) ;; #f -> transient history 48 | (recursive-edit-defaults buf defaults) 49 | (recursive-edit-history-index buf 0) 50 | (recursive-edit-new-input buf "") 51 | (recursive-edit-accept-hook buf k-accept) 52 | (recursive-edit-cancel-hook buf k-cancel) 53 | (recursive-edit-acceptable-hook buf acceptable?) 54 | (start-recursive-edit editor buf) 55 | buf) 56 | 57 | (define ((string-arg prompt 58 | #:history [history-fn minibuffer-history] 59 | #:initial [initial ""] 60 | #:defaults [defaults-fn (lambda (ed) '())] 61 | #:acceptable? [acceptable? (lambda (v) #t)]) 62 | ed sig argname k) 63 | (read-string-from-minibuffer ed prompt 64 | #:history (history-fn ed) 65 | #:initial initial 66 | #:defaults (defaults-fn ed) 67 | #:acceptable? acceptable? 68 | #:on-accept k)) 69 | 70 | (define (read-string-from-minibuffer editor 71 | prompt 72 | #:history [history (minibuffer-history editor)] 73 | #:initial [initial ""] 74 | #:defaults [defaults '()] 75 | #:acceptable? [acceptable? (lambda (v) #t)] 76 | #:on-accept k-accept 77 | #:on-cancel [k-cancel void]) 78 | (read-from-minibuffer editor 79 | prompt 80 | #:history history 81 | #:initial initial 82 | #:defaults defaults 83 | #:acceptable? acceptable? 84 | #:on-accept (lambda (result) 85 | (if (and (pair? defaults) (string=? result "")) 86 | (k-accept (car defaults)) 87 | (k-accept result))) 88 | #:on-cancel k-cancel)) 89 | 90 | (define recursive-edit-field-start (mark-type (buffer-mark-type 'recursive-edit-field-start 91 | '*minibuf* 92 | #t) 93 | 'left)) 94 | 95 | (define recursive-edit-mode 96 | (mode-add-constraints (make-mode "recursive-edit") 97 | #:dispatch-keys-before '(#:minibuf) 98 | #:interpret-commands-before '(#:minibuf))) 99 | 100 | (define-buffer-local recursive-edit-selected-window) 101 | (define-buffer-local recursive-edit-history) 102 | (define-buffer-local recursive-edit-defaults '()) 103 | (define-buffer-local recursive-edit-history-index 0) 104 | (define-buffer-local recursive-edit-new-input "") 105 | (define-buffer-local recursive-edit-accept-hook (lambda (content) (void))) 106 | (define-buffer-local recursive-edit-cancel-hook (lambda () (void))) 107 | (define-buffer-local recursive-edit-acceptable-hook (lambda (v) #t)) 108 | 109 | (define-simple-command-signature (abort-recursive-edit)) 110 | (define-simple-command-signature (exit-minibuffer)) 111 | (define-simple-command-signature (minibuf-beginning-of-line)) 112 | (define-simple-command-signature (next-history-element)) 113 | (define-simple-command-signature (previous-history-element)) 114 | 115 | (define-command recursive-edit-mode cmd:abort-recursive-edit (#:buffer buf #:editor ed) 116 | #:bind-key "C-g" 117 | (abandon-recursive-edit ed) 118 | (select-window ed (recursive-edit-selected-window buf)) 119 | ((recursive-edit-cancel-hook buf))) 120 | 121 | (define (recursive-edit-contents buf) 122 | (rope->searchable-string (buffer-region buf recursive-edit-field-start (buffer-size buf)))) 123 | 124 | (define (set-recursive-edit-contents! buf str #:notify? [notify? #t]) 125 | (buffer-region-update! buf recursive-edit-field-start (buffer-size buf) 126 | (lambda (_old) (piece->rope str)) 127 | #:notify? notify?)) 128 | 129 | (define-command recursive-edit-mode cmd:exit-minibuffer (#:buffer buf #:editor ed) 130 | #:bind-key "" 131 | #:bind-key "C-j" 132 | (define result (recursive-edit-contents buf)) 133 | (when ((recursive-edit-acceptable-hook buf) result) 134 | (abandon-recursive-edit ed) 135 | (select-window ed (recursive-edit-selected-window buf)) 136 | (define maybe-revised-result ((recursive-edit-accept-hook buf) result)) 137 | (when (string? maybe-revised-result) 138 | (history-push! (recursive-edit-history buf) maybe-revised-result)))) 139 | 140 | (define-command recursive-edit-mode cmd:minibuf-beginning-of-line (#:buffer buf #:window win) 141 | #:bind-key "C-a" 142 | #:bind-key "" 143 | (define limit (buffer-mark-pos* buf recursive-edit-field-start)) 144 | (if (and limit (> (buffer-mark-pos buf (window-point win)) limit)) 145 | (window-move-to! win limit) 146 | (buffer-move-mark-to-start-of-line! buf (window-point win)))) 147 | 148 | (define-command recursive-edit-mode cmd:next-history-element 149 | (#:buffer buf #:window win #:editor ed) 150 | #:bind-key "M-n" 151 | (adjust-history-index! ed win buf -1)) 152 | 153 | (define-command recursive-edit-mode cmd:previous-history-element 154 | (#:buffer buf #:window win #:editor ed) 155 | #:bind-key "M-p" 156 | (adjust-history-index! ed win buf 1)) 157 | 158 | (define (adjust-history-index! ed win buf delta) 159 | (define defaults (recursive-edit-defaults buf)) 160 | (define h (recursive-edit-history buf)) 161 | (define old-pos (recursive-edit-history-index buf)) 162 | (define new-pos (+ old-pos delta)) 163 | (define lo-limit (- (length defaults))) 164 | (define hi-limit (history-length h)) 165 | (when (< new-pos lo-limit) 166 | (if (zero? lo-limit) 167 | (abort "End of history; no default available") 168 | (abort "End of defaults; no next item"))) 169 | (when (> new-pos hi-limit) 170 | (abort "Beginning of history; no preceding item")) 171 | (when (zero? old-pos) 172 | (recursive-edit-new-input buf (recursive-edit-contents buf))) 173 | (recursive-edit-history-index buf new-pos) 174 | (set-recursive-edit-contents! 175 | buf 176 | (cond [(positive? new-pos) (history-ref h (- new-pos 1))] 177 | [(zero? new-pos) (recursive-edit-new-input buf)] 178 | [(negative? new-pos) (list-ref defaults (- (- new-pos) 1))]))) 179 | 180 | ;;--------------------------------------------------------------------------- 181 | 182 | (define (completing-read editor 183 | prompt 184 | completion-fn 185 | #:string=? [string=? string=?] 186 | #:history [history (minibuffer-history editor)] 187 | #:initial [initial ""] 188 | #:defaults [defaults '()] 189 | #:acceptable? [acceptable? (lambda (v) #t)] 190 | #:on-accept k-accept 191 | #:on-cancel [k-cancel void]) 192 | (define buf (read-from-minibuffer editor prompt 193 | #:history history 194 | #:initial initial 195 | #:defaults defaults 196 | #:acceptable? acceptable? 197 | #:on-accept k-accept 198 | #:on-cancel k-cancel)) 199 | (buffer-add-mode! buf completing-read-mode) 200 | (completing-read-string=?-hook buf string=?) 201 | (completing-read-completion-hook buf completion-fn) 202 | buf) 203 | 204 | (define (simple-completion collection) 205 | (define collection-strings (for/list ((c collection)) (format "~a" c))) 206 | (lambda (prefix string=?) 207 | (for/list ((c collection-strings) #:when (string-prefix? prefix c string=?)) c))) 208 | 209 | (define completing-read-mode 210 | (mode-add-constraints (make-mode "completing") 211 | #:dispatch-keys-before (list '#:minibuf recursive-edit-mode) 212 | #:interpret-commands-before (list '#:minibuf recursive-edit-mode))) 213 | 214 | (define-buffer-local completing-read-string=?-hook 215 | string=?) 216 | (define-buffer-local completing-read-completion-hook 217 | (lambda (v) (abort "completing-read-completion-hook not set"))) 218 | 219 | (define (common-string-prefix strs string=?) 220 | (if (null? (cdr strs)) 221 | (car strs) 222 | (let ((len (let loop ((i 1)) 223 | (if (and (>= (string-length (car strs)) i) 224 | (for/and ((c (cdr strs))) 225 | (and (>= (string-length c) i) 226 | (string=? (substring (car strs) 0 i) (substring c 0 i))))) 227 | (loop (+ i 1)) 228 | (- i 1))))) 229 | (substring (car strs) 0 len)))) 230 | 231 | (define-simple-command-signature (minibuffer-complete)) 232 | 233 | (define-command completing-read-mode cmd:minibuffer-complete (#:buffer buf #:editor ed) 234 | #:bind-key "" 235 | (define string=? (completing-read-string=?-hook buf)) 236 | (define prefix (recursive-edit-contents buf)) 237 | (define completions ((completing-read-completion-hook buf) prefix string=?)) 238 | (if (pair? completions) 239 | (let ((common-prefix (common-string-prefix completions string=?)) 240 | (complete? (null? (cdr completions)))) 241 | (if (string=? common-prefix prefix) 242 | ;; No progress. 243 | (if complete? 244 | (message ed "Sole completion") 245 | (message ed "Completions: ~a" completions)) 246 | ;; Some progress 247 | (buffer-region-update! buf 248 | recursive-edit-field-start 249 | (buffer-size buf) 250 | (lambda (_old) 251 | (piece->rope common-prefix))))) 252 | (message ed "No match"))) 253 | -------------------------------------------------------------------------------- /rmacs/mode.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Modes and modesets. 3 | 4 | (provide (struct-out mode) 5 | (struct-out modeset) 6 | (struct-out incomplete-key-sequence) 7 | (struct-out unbound-key-sequence) 8 | (struct-out command-invocation) 9 | (struct-out command-signature) 10 | (struct-out command-argument-spec) 11 | 12 | command-signature->list 13 | 14 | make-raw-mode 15 | make-mode 16 | mode-add-constraints 17 | mode-keymap-bind! 18 | mode-keymap-unbind! 19 | mode-keymap-rebind! 20 | mode-define-signature! 21 | mode-undefine-signature! 22 | mode-lookup-signature 23 | mode-define-command! 24 | mode-undefine-command! 25 | mode-redefine-command! 26 | mode-command-signatures 27 | 28 | make-modeset 29 | modeset-add-mode 30 | modeset-remove-mode 31 | modeset-toggle-mode 32 | modeset-keyseq-handler 33 | modeset-lookup-command 34 | modeset-lookup-signature 35 | modeset-command-signatures 36 | 37 | define-command-signature 38 | define-simple-command-signature 39 | collect-args 40 | const-arg 41 | 42 | kernel-mode 43 | kernel-modeset) 44 | 45 | (require (for-syntax syntax/parse)) 46 | (require (for-syntax racket/base)) 47 | (require (for-syntax "syntax.rkt")) 48 | 49 | (require racket/set) 50 | (require racket/match) 51 | (require (only-in racket/list filter-map)) 52 | 53 | (require "keys.rkt") 54 | (require "topsort.rkt") 55 | 56 | (struct mode (id 57 | name 58 | [keymap #:mutable] 59 | [signatures #:mutable] ;; (Hasheq Symbol Signature) 60 | [commands #:mutable] ;; (Hasheq Signature Handler) 61 | dispatch-keys-before 62 | dispatch-keys-after 63 | interpret-commands-before 64 | interpret-commands-after 65 | ) #:prefab) 66 | 67 | (struct modeset (modes 68 | key-dispatch-order 69 | command-interpretation-order 70 | ) #:prefab) 71 | 72 | (struct incomplete-key-sequence (handler) #:prefab) 73 | (struct unbound-key-sequence () #:prefab) 74 | (struct command-invocation (signature prefix-arg remaining-input) #:prefab) 75 | 76 | ;; A CommandCategory is one of 77 | ;; -- 'interactive 78 | ;; -- 'event 79 | 80 | (struct command-signature (selector ;; Symbol 81 | category ;; CommandCategory 82 | args ;; (List of Argspec) 83 | ) #:prefab) 84 | 85 | (struct command-argument-spec (name ;; Symbol 86 | value-proc 87 | ;; ^ CPS value-producing function: 88 | ;; (Editor Signature Symbol (-> Any1 Any2) -> Any3) 89 | ) #:prefab) 90 | 91 | (define (command-signature->list sig) 92 | (cons (command-signature-selector sig) 93 | (map command-argument-spec-name (command-signature-args sig)))) 94 | 95 | (define (make-raw-mode name) 96 | (mode (gensym name) 97 | name 98 | (empty-keymap) 99 | (hasheq) 100 | (hasheq) 101 | (seteq) 102 | (seteq) 103 | (seteq) 104 | (seteq))) 105 | 106 | (define (mode-add-constraints m 107 | #:dispatch-keys-before [kb '()] 108 | #:dispatch-keys-after [ka '()] 109 | #:interpret-commands-before [cb '()] 110 | #:interpret-commands-after [ca '()]) 111 | (define (convert modes) (list->seteq (for/list ((m modes)) 112 | (if (keyword? m) 113 | m 114 | (mode-id m))))) 115 | (struct-copy mode m 116 | [dispatch-keys-before 117 | (set-union (mode-dispatch-keys-before m) (convert kb))] 118 | [dispatch-keys-after 119 | (set-union (mode-dispatch-keys-after m) (convert ka))] 120 | [interpret-commands-before 121 | (set-union (mode-interpret-commands-before m) (convert cb))] 122 | [interpret-commands-after 123 | (set-union (mode-interpret-commands-after m) (convert ca))])) 124 | 125 | (define (make-mode name) 126 | (mode-add-constraints (make-raw-mode name) 127 | #:dispatch-keys-before '(#:kernel) 128 | #:interpret-commands-before '(#:kernel))) 129 | 130 | (define (mode-keymap-bind! m keyspec command) 131 | (set-mode-keymap! m (keymap-bind (mode-keymap m) keyspec command)) 132 | m) 133 | 134 | (define (mode-keymap-unbind! m keyspec) 135 | (set-mode-keymap! m (keymap-unbind (mode-keymap m) keyspec)) 136 | m) 137 | 138 | (define (mode-keymap-rebind! m keyspec command) 139 | (mode-keymap-bind! (mode-keymap-unbind! m keyspec) keyspec command)) 140 | 141 | (define (mode-define-signature! m signature) 142 | (define selector (command-signature-selector signature)) 143 | (let ((existing-sig (mode-lookup-signature m selector))) 144 | (when (and existing-sig (not (eq? existing-sig signature))) 145 | (error 'mode-define-signature! 146 | "Cannot overwrite existing signature ~a with new signature ~a in mode ~a" 147 | (command-signature->list existing-sig) 148 | (command-signature->list signature) 149 | (mode-id m)))) 150 | (set-mode-signatures! m (hash-set (mode-signatures m) selector signature)) 151 | m) 152 | 153 | (define (mode-undefine-signature! m signature) 154 | (define selector (command-signature-selector signature)) 155 | (define existing-sig (mode-lookup-signature m selector)) 156 | (when (and existing-sig (not (eq? existing-sig signature))) 157 | (error 'mode-undefine-signature! 158 | "Attempt to remove signature ~a that conflicts with existing signature ~a in mode ~a" 159 | (command-signature->list signature) 160 | (command-signature->list existing-sig) 161 | (mode-id m))) 162 | (set-mode-signatures! m (hash-remove (mode-signatures m) selector)) 163 | m) 164 | 165 | (define (mode-lookup-signature m selector) 166 | (hash-ref (mode-signatures m) selector #f)) 167 | 168 | (define (mode-define-command! m signature handler) 169 | (mode-define-signature! m signature) 170 | (when (hash-has-key? (mode-commands m) signature) 171 | (error 'mode-define-command! 172 | "Duplicate handler for command ~a in mode ~a" 173 | (command-signature->list signature) 174 | (mode-id m))) 175 | (set-mode-commands! m (hash-set (mode-commands m) signature handler)) 176 | m) 177 | 178 | (define (mode-undefine-command! m signature) 179 | (set-mode-commands! m (hash-remove (mode-commands m) signature)) 180 | m) 181 | 182 | (define (mode-redefine-command! m signature handler) 183 | (mode-define-command! (mode-undefine-command! m signature) signature handler)) 184 | 185 | (define (mode-command-signatures m) 186 | (list->seteq (hash-keys (mode-commands m)))) 187 | 188 | (define (make-modeset) 189 | (modeset (hasheq) 190 | '() 191 | '())) 192 | 193 | (define (modeset-add-mode ms m) 194 | (compute-modeset-orders 195 | (struct-copy modeset ms [modes (hash-set (modeset-modes ms) 196 | (mode-id m) 197 | m)]))) 198 | 199 | (define (modeset-remove-mode ms m) 200 | (compute-modeset-orders 201 | (struct-copy modeset ms [modes (hash-remove (modeset-modes ms) (mode-id m))]))) 202 | 203 | (define (modeset-toggle-mode ms m) 204 | ((if (hash-has-key? (modeset-modes ms) (mode-id m)) modeset-remove-mode modeset-add-mode) 205 | ms 206 | m)) 207 | 208 | (define (edges ms before-getter after-getter) 209 | (for/fold [(es '())] 210 | [(m (in-hash-values (modeset-modes ms)))] 211 | (define mid (mode-id m)) 212 | (append (for/list [(nid (before-getter m))] (list mid nid)) 213 | (for/list [(nid (after-getter m))] (list nid mid)) 214 | es))) 215 | 216 | (define (compute-modeset-order ms what before-getter after-getter) 217 | (or (topsort (edges ms before-getter after-getter) #:comparison eq?) 218 | (error 'compute-modeset-orders "Inconsistent ~a order: ~v" 219 | (hash-keys (modeset-modes ms))))) 220 | 221 | (define (compute-modeset-orders ms) 222 | (struct-copy modeset ms 223 | [key-dispatch-order (compute-modeset-order ms 224 | "key dispatch" 225 | mode-dispatch-keys-before 226 | mode-dispatch-keys-after)] 227 | [command-interpretation-order (compute-modeset-order ms 228 | "command interpretation" 229 | mode-interpret-commands-before 230 | mode-interpret-commands-after)])) 231 | 232 | (define (order->modes ms order-getter) 233 | (define modes (modeset-modes ms)) 234 | (filter-map (lambda (id) (hash-ref modes id #f)) (order-getter ms))) 235 | 236 | (define (modeset-keyseq-handler ms) 237 | (let handler-for-maps ((maps (map mode-keymap (order->modes ms modeset-key-dispatch-order)))) 238 | (lambda (e ks) 239 | (define results (map (lambda (km) 240 | (define-values (result remaining-input) (keymap-lookup km ks)) 241 | (list result remaining-input)) maps)) 242 | (let process-results ((results results)) 243 | (match results 244 | ['() (unbound-key-sequence)] 245 | [(cons (list result remaining-input) rest) 246 | (cond 247 | [(not result) (process-results rest)] 248 | [(keymap? result) (incomplete-key-sequence 249 | (handler-for-maps (filter keymap? (map car results))))] 250 | [(procedure? result) 251 | (if (null? remaining-input) 252 | (incomplete-key-sequence result) 253 | (result e remaining-input))] 254 | [(command-signature? result) 255 | (command-invocation result '#:default remaining-input)] 256 | [else (error 'modeset-keyseq-handler "Invalid keymap-lookup result: ~v" result)])]))))) 257 | 258 | (define (modeset-lookup-command ms signature) 259 | (let search ((tables (map mode-commands 260 | (order->modes ms modeset-command-interpretation-order)))) 261 | (match tables 262 | ['() #f] 263 | [(cons table rest) 264 | (match (hash-ref table signature #f) 265 | [#f (search rest)] 266 | [handler (lambda (cmd) 267 | (handler cmd 268 | (lambda ([cmd cmd]) 269 | (define next-method (search rest)) 270 | (when next-method (next-method cmd)))))])]))) 271 | 272 | (define (modeset-lookup-signature ms selector) 273 | (for/or ((m (order->modes ms modeset-command-interpretation-order))) 274 | (mode-lookup-signature m selector))) 275 | 276 | (define (modeset-command-signatures ms) 277 | (for/fold [(signatures (seteq))] [(m (hash-values (modeset-modes ms)))] 278 | (set-union signatures (mode-command-signatures m)))) 279 | 280 | (define-syntax define-command-signature 281 | (lambda (stx) 282 | (syntax-parse stx 283 | [(_ id (selector [argname argproc] ...) 284 | (~optional (~seq #:category category) #:defaults ([category #'interactive]))) 285 | #'(define id (command-signature 'selector 286 | 'category 287 | (list (command-argument-spec 'argname argproc) ...)))]))) 288 | 289 | (define-syntax define-simple-command-signature 290 | (lambda (stx) 291 | (syntax-parse stx 292 | [(_ (selector arg ...) other ...) 293 | #`(define-command-signature #,(build-name #'selector "cmd:" #'selector) 294 | (selector arg ...) 295 | other ...)]))) 296 | 297 | (define (collect-args sig editor k) 298 | (let loop ((specs (command-signature-args sig)) (acc '())) 299 | (match specs 300 | ['() 301 | (k (reverse acc))] 302 | [(cons (command-argument-spec name value-proc) rest) 303 | (value-proc editor sig name (lambda (v) (loop rest (cons v acc))))]))) 304 | 305 | (define (const-arg v) 306 | (lambda (ed sig name k) (k v))) 307 | 308 | (define kernel-mode 309 | (mode-add-constraints (make-raw-mode "kernel") 310 | #:dispatch-keys-after '(#:kernel) 311 | #:interpret-commands-after '(#:kernel))) 312 | 313 | (define kernel-modeset 314 | (modeset-add-mode (make-modeset) kernel-mode)) 315 | -------------------------------------------------------------------------------- /rmacs/mode/fundamental.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide fundamental-mode) 4 | 5 | (require racket/set) 6 | (require racket/match) 7 | (require (except-in racket/string string-prefix?)) 8 | (require "../api.rkt") 9 | (require "../strings.rkt") 10 | 11 | (define fundamental-mode 12 | (mode-add-constraints (make-mode "fundamental") 13 | #:dispatch-keys-after '(#:minibuf) 14 | #:interpret-commands-after '(#:minibuf))) 15 | 16 | (define ((read-interactive-signature prompt) ed meta-sig meta-argname k) 17 | (define buf (editor-active-buffer ed)) 18 | (define last-cmd (editor-last-command ed)) 19 | (define sigs (for/hash [(sig (modeset-command-signatures (buffer-modeset buf))) 20 | #:when (eq? (command-signature-category sig) 'interactive)] 21 | (values (command-signature-selector sig) sig))) 22 | (completing-read ed prompt 23 | (simple-completion (hash-keys sigs)) 24 | #:on-accept (lambda (content) 25 | (define selector (string->symbol content)) 26 | (define sig (hash-ref sigs selector #f)) 27 | (when (not sig) 28 | (abort "No such interactive command ~a" selector)) 29 | (set-editor-last-command! ed last-cmd) 30 | (k sig) 31 | content))) 32 | 33 | (define ((read-buffer prompt #:default-to-next? [default-to-next? #t]) ed sig argname k) 34 | (define buf (editor-active-buffer ed)) 35 | (define default-target ((if default-to-next? buffer-next values) buf)) 36 | (completing-read ed 37 | (format "~a~a: " 38 | prompt 39 | (if default-target 40 | (format " (default ~a)" (buffer-title default-target)) 41 | "")) 42 | (simple-completion (buffergroup-buffer-titles (editor-buffers ed))) 43 | #:on-accept (lambda (title0) 44 | (define title1 (string-trim title0)) 45 | (define title (if (equal? title1 "") #f title1)) 46 | (define target (if title (find-buffer ed title) default-target)) 47 | (k target) 48 | (buffer-title target)))) 49 | 50 | (define ((read-filesystem-path) ed sig argname k) 51 | (local-require racket/path) 52 | (define buf (editor-active-buffer ed)) 53 | (define src (and buf (buffer-source buf))) 54 | (completing-read ed 55 | "Find file: " 56 | (lambda (prefix0 string=?) 57 | (define prefix (simplify-path prefix0)) 58 | (define-values (dirname filename) 59 | (let-values (((d f dir?) (split-path prefix))) 60 | (if dir? 61 | (values (path->string prefix) #f) 62 | (values (path->string d) (path->string f))))) 63 | (for/list ((p (directory-list dirname)) 64 | #:when (or (not filename) 65 | (string-prefix? filename (path->string p) string=?))) 66 | (define q (path->string (build-path dirname p))) 67 | (if (directory-exists? q) (string-append q "/") q))) 68 | #:initial 69 | (if src 70 | (string-append 71 | (path->string (normalize-path 72 | (simplify-path (build-path (buffer-source-path src) 'up)))) 73 | "/") 74 | (path->string (normalize-path "."))) 75 | #:on-accept (lambda (str) 76 | (k str)))) 77 | 78 | (define-simple-command-signature (quoted-insert)) 79 | (define-simple-command-signature (newline)) 80 | (define-simple-command-signature (indent-for-tab-command)) 81 | (define-simple-command-signature (forward-char)) 82 | (define-simple-command-signature (backward-char)) 83 | (define-simple-command-signature (next-line)) 84 | (define-simple-command-signature (prev-line)) 85 | (define-simple-command-signature (move-end-of-line)) 86 | (define-simple-command-signature (move-beginning-of-line)) 87 | (define-simple-command-signature (delete-backward-char)) 88 | (define-simple-command-signature (delete-forward-char)) 89 | (define-simple-command-signature (beginning-of-buffer)) 90 | (define-simple-command-signature (end-of-buffer)) 91 | (define-simple-command-signature (exchange-point-and-mark)) 92 | (define-simple-command-signature (set-mark-command)) 93 | (define-simple-command-signature (split-window-below)) 94 | (define-simple-command-signature (delete-other-windows)) 95 | (define-simple-command-signature (delete-window)) 96 | (define-simple-command-signature (other-window)) 97 | (define-simple-command-signature (save-buffer)) 98 | (define-simple-command-signature 99 | (execute-extended-command [signature (read-interactive-signature "M-x ")])) 100 | (define-simple-command-signature 101 | (switch-to-buffer [target-buffer (read-buffer "Switch to buffer")])) 102 | (define-simple-command-signature 103 | (kill-buffer [target-buffer (read-buffer "Kill buffer" #:default-to-next? #f)])) 104 | (define-simple-command-signature (kill-region)) 105 | (define-simple-command-signature (yank)) 106 | (define-simple-command-signature (yank-pop)) 107 | (define-simple-command-signature (append-next-kill)) 108 | (define-simple-command-signature (copy-region-as-kill)) 109 | (define-simple-command-signature (kill-ring-save)) 110 | (define-simple-command-signature (kill-line)) 111 | (define-simple-command-signature (undo)) 112 | (define-simple-command-signature (find-file [path (read-filesystem-path)])) 113 | (define-simple-command-signature (scroll-up-command)) 114 | (define-simple-command-signature (scroll-down-command)) 115 | 116 | (define (default-search-pattern ed) 117 | (cond [(history-ref (minibuffer-history ed) 0) => list] 118 | [else '()])) 119 | 120 | (define-simple-command-signature 121 | (search-forward [needle (string-arg "Search: " #:defaults default-search-pattern)])) 122 | (define-simple-command-signature 123 | (search-backward [needle (string-arg "Search backward: " #:defaults default-search-pattern)])) 124 | (define-simple-command-signature 125 | (search-forward-regexp [needle (string-arg "Regexp search: " #:defaults default-search-pattern)])) 126 | 127 | (define (self-insert-command cmd) 128 | (match (command-keyseq cmd) 129 | [(list (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift)) 130 | (buffer-insert! (command-buffer cmd) 131 | (window-point (command-window cmd)) 132 | (piece->rope (string ch)))] 133 | [_ #f])) 134 | 135 | (define-command fundamental-mode cmd:unbound-key-sequence (#:command cmd) 136 | (self-insert-command cmd)) 137 | 138 | (define-command fundamental-mode cmd:quoted-insert (#:buffer buf #:window win #:keyseq keyseq) 139 | #:bind-key "C-q #:default" 140 | (match keyseq 141 | [(list _ (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift)) 142 | (buffer-insert! buf (window-point win) (piece->rope (string ch)))] 143 | [(list _ (key (? char? ch0) modifiers)) #:when (equal? modifiers (set 'control)) 144 | (define ch (integer->char (- (char->integer (char-upcase ch0)) (char->integer #\A) -1))) 145 | (buffer-insert! buf (window-point win) (piece->rope (string ch)))] 146 | [_ #f])) 147 | 148 | (define-command fundamental-mode cmd:newline (#:buffer buf #:window win) 149 | #:bind-key "" 150 | #:bind-key "C-j" 151 | (buffer-insert! buf (window-point win) (piece->rope "\n"))) 152 | 153 | (define-command fundamental-mode cmd:indent-for-tab-command (#:buffer buf #:window win) 154 | #:bind-key "" 155 | (buffer-insert! buf (window-point win) (piece->rope "\t"))) 156 | 157 | (define (plus-n-lines buf pos count) 158 | (for/fold [(pos pos)] [(i (in-range count))] (+ (buffer-end-of-line buf pos) 1))) 159 | 160 | (define (minus-n-lines buf pos count) 161 | (for/fold [(pos pos)] [(i (in-range count))] (- (buffer-start-of-line buf pos) 1))) 162 | 163 | (define (move-forward-n-lines win count) 164 | (define buf (window-buffer win)) 165 | (buffer-mark! buf (window-point win) (plus-n-lines buf (window-point win) count))) 166 | 167 | (define (move-backward-n-lines win count) 168 | (define buf (window-buffer win)) 169 | (buffer-mark! buf (window-point win) (minus-n-lines buf (window-point win) count))) 170 | 171 | (define (move-to-column win col) 172 | (define buf (window-buffer win)) 173 | (define sol (buffer-start-of-line buf (window-point win))) 174 | (buffer-mark! buf (window-point win) (buffer-closest-pos-for-column buf sol 0 col))) 175 | 176 | (define-command fundamental-mode cmd:forward-char 177 | (#:buffer buf #:window win #:prefix-arg [count 1]) 178 | #:bind-key "C-f" 179 | #:bind-key "" 180 | (buffer-move-mark! buf (window-point win) count)) 181 | 182 | (define-command fundamental-mode cmd:backward-char 183 | (#:buffer buf #:window win #:prefix-arg [count 1]) 184 | #:bind-key "C-b" 185 | #:bind-key "" 186 | (buffer-move-mark! buf (window-point win) (- count))) 187 | 188 | (define-buffer-local last-vertical-movement-preferred-column) 189 | 190 | (define (vertical-movement-preferred-column editor win) 191 | (define buf (window-buffer win)) 192 | (last-vertical-movement-preferred-column 193 | buf 194 | (or (and (editor-last-command? editor 195 | cmd:next-line 196 | cmd:prev-line) 197 | (last-vertical-movement-preferred-column buf)) 198 | (buffer-column buf (window-point win))))) 199 | 200 | (define-command fundamental-mode cmd:next-line (#:window win #:editor ed #:prefix-arg [count 1]) 201 | #:bind-key "C-n" 202 | #:bind-key "" 203 | (define col (vertical-movement-preferred-column ed win)) 204 | (move-forward-n-lines win count) 205 | (move-to-column win col)) 206 | 207 | (define-command fundamental-mode cmd:prev-line (#:window win #:editor ed #:prefix-arg [count 1]) 208 | #:bind-key "C-p" 209 | #:bind-key "" 210 | (define col (vertical-movement-preferred-column ed win)) 211 | (move-backward-n-lines win count) 212 | (move-to-column win col)) 213 | 214 | (define-command fundamental-mode cmd:move-end-of-line 215 | (#:buffer buf #:window win #:prefix-arg [count 1]) 216 | #:bind-key "C-e" 217 | #:bind-key "" 218 | (when (positive? count) (move-forward-n-lines win (- count 1))) 219 | (buffer-move-mark-to-end-of-line! buf (window-point win))) 220 | 221 | (define-command fundamental-mode cmd:move-beginning-of-line 222 | (#:buffer buf #:window win #:prefix-arg [count 1]) 223 | #:bind-key "C-a" 224 | #:bind-key "" 225 | (when (positive? count) (move-forward-n-lines win (- count 1))) 226 | (buffer-move-mark-to-start-of-line! buf (window-point win))) 227 | 228 | (define-command fundamental-mode cmd:delete-backward-char 229 | (#:buffer buf #:window win #:prefix-arg [count 1]) 230 | #:bind-key "" 231 | #:bind-key "C-h" ;; differs from GNU emacs 232 | (define pos (buffer-mark-pos buf (window-point win))) 233 | (buffer-region-update! buf (- pos 1) pos (lambda (_deleted) (rope-empty)))) 234 | 235 | (define-command fundamental-mode cmd:delete-forward-char 236 | (#:buffer buf #:window win #:prefix-arg [count 1]) 237 | #:bind-key "" 238 | #:bind-key "C-d" 239 | (define pos (buffer-mark-pos buf (window-point win))) 240 | (buffer-region-update! buf pos (+ pos 1) (lambda (_deleted) (rope-empty)))) 241 | 242 | (define (set-mark! win [pos (window-point win)] #:noisy? [noisy? #t]) 243 | (buffer-mark! (window-buffer win) region-mark pos) 244 | (when (and noisy? (window-editor win)) (message (window-editor win) "Mark set")) 245 | pos) 246 | 247 | (define-command fundamental-mode cmd:beginning-of-buffer 248 | (#:buffer buf #:window win #:prefix-arg [tenths 0]) 249 | #:bind-key "M-<" 250 | #:bind-key "S-M-<" 251 | #:bind-key "S-M-," ;; OS X for some reason! 252 | #:bind-key "C-" 253 | #:bind-key "" 254 | (if (eq? tenths '#:universal) (set! tenths 0) (set-mark! win)) 255 | (window-move-to! win (* (buffer-size buf) (max 0 (min 10 tenths)) 1/10))) 256 | 257 | (define-command fundamental-mode cmd:end-of-buffer 258 | (#:buffer buf #:window win #:prefix-arg [tenths 0]) 259 | #:bind-key "M->" 260 | #:bind-key "S-M->" 261 | #:bind-key "S-M-." ;; OS X for some reason! 262 | #:bind-key "C-" 263 | (if (eq? tenths '#:universal) (set! tenths 0) (set-mark! win)) 264 | (window-move-to! win (* (buffer-size buf) (- 10 (max 0 (min 10 tenths))) 1/10))) 265 | 266 | (define-command fundamental-mode cmd:exchange-point-and-mark (#:buffer buf #:window win) 267 | #:bind-key "C-x C-x" 268 | (define m (buffer-mark-pos* buf region-mark)) 269 | (when m 270 | (set-mark! win #:noisy? #f) 271 | (window-move-to! win m))) 272 | 273 | (define-command fundamental-mode cmd:set-mark-command (#:buffer buf #:window win #:prefix-arg arg) 274 | #:bind-key "C-@" 275 | #:bind-key "C-space" 276 | (if (eq? arg '#:universal) 277 | (let ((m (buffer-mark-pos* buf region-mark))) 278 | (and m (window-move-to! win m))) 279 | (set-mark! win))) 280 | 281 | (define-command fundamental-mode cmd:split-window-below (#:buffer buf #:window win #:editor ed) 282 | #:bind-key "C-x 2" 283 | (open-window ed buf #:after-window win #:activate? #f)) 284 | 285 | (define-command fundamental-mode cmd:delete-other-windows (#:window win #:editor ed) 286 | #:bind-key "C-x 1" 287 | (close-other-windows ed win)) 288 | 289 | (define-command fundamental-mode cmd:delete-window (#:window win #:editor ed) 290 | #:bind-key "C-x 0" 291 | (close-window ed win)) 292 | 293 | (define-command fundamental-mode cmd:other-window (#:window win #:editor ed) 294 | #:bind-key "C-" 295 | #:bind-key "C-x o" 296 | (select-window ed (editor-next-window ed win))) 297 | 298 | (define-command fundamental-mode cmd:save-buffer (#:buffer buf #:editor ed) 299 | #:bind-key "C-x C-s" 300 | (save-buffer! buf) 301 | (undo-list buf (map (match-lambda [(list was-dirty? pos old new) (list #t pos old new)]) 302 | (undo-list buf))) 303 | (message ed "Wrote ~a" (path->string (buffer-source-path (buffer-source buf))))) 304 | 305 | (define-command fundamental-mode cmd:execute-extended-command 306 | (signature #:editor ed #:prefix-arg prefix) 307 | #:bind-key "M-x" 308 | (collect-args-and-invoke/history ed signature #f prefix)) 309 | 310 | (define-command fundamental-mode cmd:switch-to-buffer (target-buffer #:window win) 311 | #:bind-key "C-x b" 312 | (buffer-reorder! target-buffer) 313 | (set-window-buffer! win target-buffer)) 314 | 315 | (define-command fundamental-mode cmd:kill-buffer (target-buffer #:editor ed) 316 | #:bind-key "C-x k" 317 | (find-buffer ed "*scratch*") ;; side-effect: ensures a scratch buffer exists. 318 | (when (> (buffergroup-count (editor-buffers ed)) 1) 319 | ;; We don't do anything when there's just one buffer (i.e. the 320 | ;; scratch buffer, per side effect above) left, because otherwise 321 | ;; we'd be left with no buffers at all, which would leave our 322 | ;; windows with nothing to display, etc. 323 | (for [(win (windows-for-buffer ed target-buffer))] 324 | (when (eq? (window-buffer win) target-buffer) 325 | (set-window-buffer! win (buffer-next (window-buffer win))))) 326 | (register-buffer! #f target-buffer))) 327 | 328 | (define-editor-local kill-ring*) 329 | (define-command-local kill-command?) 330 | 331 | (define (kill-ring editor) 332 | (when (not (kill-ring* editor)) 333 | (kill-ring* editor (make-ring))) 334 | (kill-ring* editor)) 335 | 336 | (define (copy-region-as-kill! cmd ed region) 337 | (define full-region (if (kill-command? (editor-last-command ed)) 338 | (rope-append (ring-remove-item! (kill-ring ed)) region) 339 | region)) 340 | (ring-add-item! (kill-ring ed) (clear-all-marks full-region)) 341 | (kill-command? cmd #t) 342 | region) 343 | 344 | (define (kill-region! cmd ed buf pm1 pm2) 345 | (buffer-region-update! buf pm1 pm2 (lambda (region) 346 | (copy-region-as-kill! cmd ed region) 347 | (rope-empty)))) 348 | 349 | (define (yank! ed buf pm #:index [index 0]) 350 | (define region (ring-ref (kill-ring ed) index)) 351 | (buffer-insert! buf pm region)) 352 | 353 | (define (mark-pos-or-die buf) 354 | (or (buffer-mark-pos* buf region-mark) 355 | (abort "The mark is not set now, so there is no region"))) 356 | 357 | (define-command fundamental-mode cmd:kill-region 358 | (#:buffer buf #:window win #:editor ed #:command cmd) 359 | #:bind-key "C-w" 360 | #:bind-key "S-" 361 | (kill-region! cmd ed buf (window-point win) (mark-pos-or-die buf))) 362 | 363 | (define-command fundamental-mode cmd:yank (#:buffer buf #:window win #:editor ed) 364 | #:bind-key "C-y" 365 | #:bind-key "S-" 366 | (set-mark! win) 367 | (yank! ed buf (window-point win))) 368 | 369 | (define-command fundamental-mode cmd:yank-pop (#:buffer buf #:window win #:editor ed) 370 | #:bind-key "M-y" 371 | (if (editor-last-command? ed cmd:yank cmd:yank-pop) 372 | (buffer-region-update! buf (window-point win) (mark-pos-or-die buf) 373 | (lambda (previously-yanked-region) 374 | (ring-rotate! (kill-ring ed) 1) 375 | (ring-ref (kill-ring ed)))) 376 | (abort "Previous command was not a yank"))) 377 | 378 | (define-command fundamental-mode cmd:append-next-kill (#:command cmd #:editor ed) 379 | #:bind-key "C-M-w" 380 | (message ed "If the next command is a kill, it will append") 381 | (kill-command? cmd #t)) 382 | 383 | (define-command fundamental-mode cmd:copy-region-as-kill 384 | (#:buffer buf #:window win #:editor ed #:command cmd) 385 | (copy-region-as-kill! cmd ed (buffer-region buf (window-point win) (mark-pos-or-die buf)))) 386 | 387 | (define (temporarily-move-cursor-to ed win buf pos) 388 | (define point (buffer-mark-pos buf (window-point win))) 389 | (buffer-mark! buf (window-point win) pos) 390 | (editor-sit-for ed 1) 391 | (buffer-mark! buf (window-point win) point)) 392 | 393 | (define-command fundamental-mode cmd:kill-ring-save 394 | (#:buffer buf #:window win #:editor ed #:command cmd) 395 | #:bind-key "M-w" 396 | #:bind-key "C-" 397 | (define mark (mark-pos-or-die buf)) 398 | (define point (buffer-mark-pos buf (window-point win))) 399 | (define region (copy-region-as-kill! cmd ed (buffer-region buf point mark))) 400 | (if (position-visible? win mark) 401 | (temporarily-move-cursor-to ed win buf mark) 402 | (let-values (((lo hi) (if (< point mark) 403 | (values (- mark 40) mark) 404 | (values mark (+ mark 40))))) 405 | (define snippet (rope->searchable-string (buffer-region buf lo hi))) 406 | (message ed "Saved text ~a \"~a\"" (if (< point mark) "until" "from") snippet)))) 407 | 408 | (define-command fundamental-mode cmd:kill-line 409 | (#:buffer buf #:window win #:editor ed #:command cmd #:prefix-arg count) 410 | #:bind-key "C-k" 411 | (define point (buffer-mark-pos buf (window-point win))) 412 | (define-values (start end) 413 | (cond 414 | [(eq? count '#:default) 415 | (define eol (buffer-end-of-line buf (window-point win))) 416 | (if (= point eol) 417 | (values point (+ point 1)) 418 | (values point eol))] 419 | [(positive? count) 420 | (values (window-point win) 421 | (buffer-end-of-line buf (plus-n-lines buf (window-point win) (- count 1))))] 422 | [else 423 | (values (buffer-start-of-line buf (minus-n-lines buf (window-point win) (- count))) 424 | (window-point win))])) 425 | (kill-region! cmd ed buf start end)) 426 | 427 | (define (search-in-buffer ed win buf mode needle) 428 | (when (positive? (string-length needle)) 429 | (define pos+len 430 | (case mode 431 | [(forward) (buffer-search buf (window-point win) needle #:forward? #t)] 432 | [(backward) (buffer-search buf (window-point win) needle #:forward? #f)] 433 | [(forward-regexp) (buffer-search-regexp buf (window-point win) needle)])) 434 | (if (not pos+len) 435 | (message ed 436 | (case mode 437 | [(forward) "Failing search: ~a"] 438 | [(backward) "Failing search backward: ~a"] 439 | [(forward-regexp) "Failing regexp search: ~a"]) 440 | needle) 441 | (let ((newpos (+ (car pos+len) 442 | (case mode 443 | [(forward forward-regexp) (cdr pos+len)] 444 | [(backward) 0])))) 445 | (set-mark! win #:noisy? #f) 446 | (message ed "Mark saved where search started") 447 | (buffer-mark! buf (window-point win) newpos))) 448 | needle)) 449 | 450 | (define-command fundamental-mode cmd:search-forward (needle #:buffer buf #:window win #:editor ed) 451 | #:bind-key "C-s" 452 | (search-in-buffer ed win buf 'forward needle)) 453 | 454 | (define-command fundamental-mode cmd:search-backward (needle #:buffer buf #:window win #:editor ed) 455 | #:bind-key "C-r" 456 | (search-in-buffer ed win buf 'backward needle)) 457 | 458 | (define-command fundamental-mode cmd:search-forward-regexp 459 | (needle #:buffer buf #:window win #:editor ed) 460 | #:bind-key "C-M-s" 461 | (search-in-buffer ed win buf 'forward-regexp needle)) 462 | 463 | (define-buffer-local undo-list '()) 464 | (define-command-local repeated-undo-list) 465 | 466 | (define undo-insertion-coalesce-limit 20) 467 | 468 | (define-command fundamental-mode cmd:buffer-changed 469 | (was-dirty? pos old-content new-content #:buffer buf) 470 | (undo-list buf 471 | (match (undo-list buf) 472 | [(cons (list prev-was-dirty? prev-pos (? rope-empty?) prev-insertion) rest) 473 | #:when (and (rope-empty? old-content) 474 | (= prev-pos (- pos (rope-size prev-insertion))) 475 | (< (+ (rope-size prev-insertion) (rope-size new-content)) 476 | undo-insertion-coalesce-limit)) 477 | (cons (list prev-was-dirty? 478 | prev-pos 479 | old-content 480 | (rope-append prev-insertion new-content)) 481 | rest)] 482 | [rest 483 | (cons (list was-dirty? pos old-content new-content) rest)]))) 484 | 485 | (define-command fundamental-mode cmd:undo (#:command cmd #:buffer buf #:window win #:editor ed) 486 | #:bind-key "C-_" 487 | #:bind-key "C-S-_" 488 | #:bind-key "C-/" 489 | #:bind-key "C-x u" 490 | (define actions (or (repeated-undo-list (editor-last-command ed)) (undo-list buf))) 491 | (match actions 492 | ['() (abort "No further undo information")] 493 | [(cons (list was-dirty? pos old-content new-content) rest) 494 | (repeated-undo-list cmd rest) 495 | (buffer-region-update! buf pos (+ pos (rope-size new-content)) 496 | (lambda (_new-content-again) old-content)) 497 | (buffer-mark! buf (window-point win) (+ pos (rope-size old-content))) 498 | (when (not was-dirty?) (mark-buffer-clean! buf))])) 499 | 500 | (define-command fundamental-mode cmd:find-file (path #:editor ed) 501 | #:bind-key "C-x C-f" 502 | (visit-file! ed path)) 503 | 504 | (define-command fundamental-mode cmd:scroll-up-command (#:buffer buf #:window win) 505 | #:bind-key "C-v" 506 | #:bind-key "" 507 | (define new-pos (buffer-start-of-line buf (minus-n-lines buf (window-bottom win) 1))) 508 | (buffer-mark! buf (window-point win) new-pos) 509 | (buffer-mark! buf (window-top win) new-pos)) 510 | 511 | (define-command fundamental-mode cmd:scroll-down-command (#:buffer buf #:window win) 512 | #:bind-key "M-v" 513 | #:bind-key "" 514 | (define scroll-count (- (window-available-line-count win) 2)) 515 | (define new-top (buffer-start-of-line buf (minus-n-lines buf (window-top win) scroll-count))) 516 | (buffer-mark! buf (window-point win) (window-top win)) 517 | (buffer-mark! buf (window-top win) new-top)) 518 | -------------------------------------------------------------------------------- /rmacs/render.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (struct-out absolute-size) 4 | (struct-out relative-size) 5 | (struct-out layout) 6 | color-mark 7 | layout-windows 8 | render-windows!) 9 | 10 | (require racket/match) 11 | 12 | (require "buffer.rkt") 13 | (require "window.rkt") 14 | (require "display.rkt") 15 | (require "rope.rkt") 16 | (require "mark.rkt") 17 | (require "wrap.rkt") 18 | 19 | ;; A SizeSpec is either 20 | ;; -- (absolute-size PositiveInteger), a specific size in screen rows 21 | ;; -- (relative-size PositiveReal), a weighted window size 22 | (struct absolute-size (lines) #:prefab) 23 | (struct relative-size (weight) #:prefab) 24 | 25 | ;; A Layout is a (layout Window SizeSpec Nat Nat) 26 | (struct layout (window ;; Window 27 | size-spec ;; SizeSpec 28 | top ;; Nat, a row 29 | left ;; Nat, a column 30 | ) #:prefab) 31 | 32 | ;; When present in a rope, associated with a Pen value (see display.rkt) 33 | (define color-mark (mark-type (buffer-mark-type 'color #f #f) 'right)) 34 | 35 | ;; Finseth's book defines a C routine, Framer(), which is intended to 36 | ;; ensure that the `top_of_window` mark, denoting the position where 37 | ;; display should begin for the current window, is in a sane position. 38 | ;; The mark is left alone unless the cursor is outside the currently 39 | ;; displayed window, either above or below. If the mark needs to be 40 | ;; moved, it is moved to a line such that the cursor, after redisplay, 41 | ;; will end up at a configurable percentage of the way down the 42 | ;; window. 43 | ;; 44 | ;; It is here that we perform soft-wrapping of lines. 45 | ;; 46 | ;; Window Nat -> (List (Pair Nat Nat)) 47 | ;; Ensures that window-top is sanely positioned with respect to 48 | ;; window-point. Returns wrapped line spans starting at the new 49 | ;; window-top. 50 | (define (frame! win available-line-count window-width 51 | #:preferred-position-fraction [preferred-position-fraction 1/2]) 52 | (define buf (window-buffer win)) 53 | (define old-top-of-window-pos (or (buffer-mark-pos* buf (window-top win)) 0)) 54 | (define preferred-distance-from-bottom 55 | (min (floor (* available-line-count preferred-position-fraction)) 56 | (- available-line-count 1))) 57 | (define g (buffer-lines-reverse/wrap buf (window-point win) basic-wrap window-width)) 58 | (define spans 59 | (let loop ((line-count 0) 60 | (all-spans '()) 61 | (preferred-spans '())) 62 | (define-values (pos eol-pos) (g)) 63 | (define span (cons pos eol-pos)) 64 | (define new-all-spans (cons span all-spans)) 65 | (define new-preferred-spans (if (= line-count preferred-distance-from-bottom) 66 | new-all-spans 67 | preferred-spans)) 68 | (cond 69 | [(not pos) all-spans] ;; we hit buffer top before our preferred distance. NB all-spans 70 | [(= pos old-top-of-window-pos) new-all-spans] 71 | [(>= line-count (- available-line-count 1)) new-preferred-spans] 72 | [else (loop (+ line-count 1) new-all-spans new-preferred-spans)]))) 73 | (buffer-mark! buf (window-top win) (caar spans)) 74 | spans) 75 | 76 | (define (tty-statusline-style t is-active?) 77 | (tty-set-pen! t (pen color-black color-white #f #f))) 78 | 79 | (define (render-colored-line t buf sol-pos eol-pos) 80 | (define first-color (cond [(buffer-mark* buf color-mark #:forward? #f #:position sol-pos) => cdr] 81 | [else tty-default-pen])) 82 | (let loop ((pos sol-pos) (color first-color)) 83 | (when (< pos eol-pos) 84 | (define next-mark (buffer-mark* buf color-mark #:position (+ pos 1))) 85 | (define next-pos (if (and next-mark (<= (car next-mark) eol-pos)) 86 | (car next-mark) 87 | eol-pos)) 88 | (define str (rope->searchable-string (buffer-region buf pos next-pos))) 89 | (tty-set-pen! t color) 90 | (tty-display t str) 91 | (loop next-pos (if next-mark (cdr next-mark) color)))) 92 | (tty-newline t)) 93 | 94 | (define (render-window! t win window-top is-active?) 95 | (define buf (window-buffer win)) 96 | (define available-line-count (window-available-line-count win)) 97 | (define spans (frame! win available-line-count (window-width win))) 98 | (define cursor-pos (buffer-mark-pos buf (window-point win))) 99 | (tty-goto t window-top 0) 100 | 101 | (define (render-span sol-pos eol-pos line-count cursor-coordinates) 102 | (render-colored-line t buf sol-pos eol-pos) 103 | (if (<= sol-pos cursor-pos eol-pos) 104 | (let* ((line (rope->searchable-string (buffer-region buf sol-pos eol-pos))) 105 | (line-to-cursor (substring line 0 (- cursor-pos sol-pos)))) 106 | (list (+ line-count window-top) 107 | (buffer-string-column-count buf 0 line-to-cursor))) 108 | cursor-coordinates)) 109 | 110 | (define (render-top-spans spans line-count max-rendered-pos cursor-coordinates) 111 | (cond 112 | [(>= line-count available-line-count) (values max-rendered-pos cursor-coordinates)] 113 | [(null? spans) 114 | (define g (buffer-lines-forward/wrap buf (window-point win) basic-wrap (window-width win))) 115 | (g) ;; discard first span, since it has already been covered 116 | (render-bottom-spans g line-count max-rendered-pos cursor-coordinates)] 117 | [else 118 | (render-top-spans (cdr spans) 119 | (+ line-count 1) 120 | (cdar spans) 121 | (render-span (caar spans) (cdar spans) line-count cursor-coordinates))])) 122 | 123 | (define (render-bottom-spans g line-count max-rendered-pos cursor-coordinates) 124 | (if (>= line-count available-line-count) 125 | (values max-rendered-pos cursor-coordinates) 126 | (let-values (((sol-pos eol-pos) (g))) 127 | (if sol-pos 128 | (render-bottom-spans g 129 | (+ line-count 1) 130 | eol-pos 131 | (render-span sol-pos eol-pos line-count cursor-coordinates)) 132 | (begin (for ((i (- available-line-count line-count))) (tty-newline t)) 133 | (values max-rendered-pos cursor-coordinates)))))) 134 | 135 | (define-values (max-rendered-pos cursor-coordinates) (render-top-spans spans 0 #f #f)) 136 | 137 | (when (window-status-line? win) 138 | (tty-statusline-style t is-active?) 139 | (let* ((prefix (format "-:~a- ~a " (if (buffer-dirty? buf) "**" "--") (buffer-title buf))) 140 | (remaining-length (- (tty-columns t) (string-length prefix)))) 141 | (tty-display t prefix) 142 | (when (positive? remaining-length) (tty-display t (make-string remaining-length #\-))))) 143 | 144 | (buffer-mark! buf (window-bottom win) max-rendered-pos) 145 | cursor-coordinates) 146 | 147 | (define (layout! w size-spec top left width height) 148 | (set-window-width! w width) 149 | (set-window-height! w height) 150 | (layout w size-spec top left)) 151 | 152 | (define (layout-windows ws miniwin total-width total-height [minimum-height 4]) 153 | (define miniwin-spans 154 | (frame! miniwin (min 4 total-height) total-width #:preferred-position-fraction 1)) 155 | (define miniwin-height (length miniwin-spans)) 156 | (define total-weight (foldl + 0 (map (lambda (e) 157 | (match (cadr e) 158 | [(absolute-size _) 0] 159 | [(relative-size w) w])) ws))) 160 | (define reserved-lines (foldl + miniwin-height (map (lambda (e) 161 | (match (cadr e) 162 | [(absolute-size lines) lines] 163 | [(relative-size _) 0])) ws))) 164 | (define proportional-lines (- total-height reserved-lines)) 165 | (define ws-without-miniwin ;; miniwin is in ws when minibuffer active; otherwise, not 166 | (filter (lambda (e) (not (eq? (car e) miniwin))) ws)) 167 | (append (let loop ((ws ws-without-miniwin) (offset 0) (remaining proportional-lines)) 168 | (match ws 169 | ['() '()] 170 | [(cons (list (== miniwin eq?) _) rest) 171 | (loop rest offset remaining)] 172 | [(cons (list w (and spec (absolute-size lines))) rest) 173 | (cons (layout! w spec offset 0 total-width lines) 174 | (loop rest (+ offset lines) remaining))] 175 | [(cons (list w (and spec (relative-size weight))) rest) 176 | (define height (max minimum-height 177 | (inexact->exact 178 | (round (* proportional-lines (/ weight total-weight)))))) 179 | (if (>= remaining height) 180 | (if (null? rest) 181 | (list (layout! w spec offset 0 total-width remaining)) 182 | (cons (layout! w spec offset 0 total-width height) 183 | (loop rest (+ offset height) (- remaining height)))) 184 | (if (>= remaining minimum-height) 185 | (list (layout! w spec offset 0 total-width remaining)) 186 | '()))])) 187 | (list (layout! miniwin 188 | (absolute-size miniwin-height) 189 | (- total-height miniwin-height) 190 | 0 191 | total-width 192 | miniwin-height)))) 193 | 194 | (define (render-windows! t layouts active-window) 195 | (tty-goto t 0 0) 196 | (define active-cursor-position 197 | (for/fold [(cursor-position #f)] [(e layouts)] 198 | (match-define (layout w _spec window-top _left) e) 199 | (define is-active? (eq? w active-window)) 200 | (define window-cursor-position 201 | (render-window! t w window-top is-active?)) 202 | (if is-active? window-cursor-position cursor-position))) 203 | (when active-cursor-position 204 | (tty-goto t (car active-cursor-position) (cadr active-cursor-position))) 205 | (tty-set-title! t (buffer-title (window-buffer active-window))) 206 | (tty-flush t)) 207 | -------------------------------------------------------------------------------- /rmacs/ring.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (struct-out ring) 4 | make-ring 5 | ring-ref 6 | ring-rotate! 7 | ring-add-item! 8 | ring-remove-item! 9 | ) 10 | 11 | (require racket/match) 12 | (require "circular-list.rkt") 13 | 14 | ;; A Ring is a (ring CircularList Nat). 15 | (struct ring ([items #:mutable] 16 | max-count 17 | ) #:prefab) 18 | 19 | (define (make-ring [items circular-empty] #:max-count [max-count 60]) 20 | (ring items max-count)) 21 | 22 | (define (ring-ref ring [index 0]) 23 | (circular-list-ref (ring-items ring) index)) 24 | 25 | (define (ring-rotate! ring [count 0]) 26 | (set-ring-items! ring (circular-list-rotate (ring-items ring) count))) 27 | 28 | (define (ring-add-item! ring item) 29 | (define items (circular-cons item (ring-items ring))) 30 | (set-ring-items! ring (if (> (circular-length items) (ring-max-count ring)) 31 | (circular-butlast items) 32 | items))) 33 | 34 | (define (ring-remove-item! ring) 35 | (match (ring-items ring) 36 | [(circular-cons item rest) 37 | (set-ring-items! ring rest) 38 | item])) 39 | -------------------------------------------------------------------------------- /rmacs/rope.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Ropes for text, attributes, etc 3 | 4 | (provide (rename-out [rope?* rope?]) 5 | rope-empty? 6 | rope-empty 7 | piece->rope 8 | 9 | rope-piece 10 | update-piece 11 | 12 | rope-size 13 | rope-index 14 | rope-seek 15 | rope-split 16 | rope-append 17 | rope-concat 18 | subrope 19 | 20 | find-in-index 21 | find-pos-in-index 22 | find-all-in-index 23 | rope-map 24 | rope-map/key 25 | 26 | in-rope 27 | rope->piece-list 28 | rope->searchable-string 29 | rope->searchable-generator 30 | rope->searchable-port 31 | ) 32 | 33 | (require racket/stream) 34 | (require (only-in racket/string string-append*)) 35 | (require racket/match) 36 | 37 | (require "rope/piece.rkt") 38 | (require "rope/index.rkt") 39 | (require "rope/range.rkt") 40 | (require "rope/string.rkt") 41 | 42 | ;; A Rope is a splay tree representing a long piece of text. 43 | ;; #f is the empty Rope; otherwise a (rope) struct instance. 44 | (struct rope (piece ;; Piece 45 | left ;; Rope (possibly empty) 46 | right ;; Rope (possibly empty) 47 | size* ;; Number, total length of this rope 48 | index* ;; Index 49 | ) #:prefab) 50 | 51 | (define (rope-empty? r) (eq? r #f)) 52 | 53 | (define-match-expander rope-empty 54 | (syntax-rules () [(_) #f]) 55 | (syntax-rules () [(_) #f])) 56 | 57 | (define (rope?* r) 58 | (or (rope-empty? r) 59 | (rope? r))) 60 | 61 | (define (make-rope p l r) 62 | (if (piece-empty? p) 63 | (rope-append l r) 64 | (reindex (rope p l r (piece-size p) #f)))) 65 | 66 | (define (piece->rope p) 67 | (make-rope p (rope-empty) (rope-empty))) 68 | 69 | (define (rope-size r) 70 | (match r 71 | [(rope-empty) 0] 72 | [_ (rope-size* r)])) 73 | 74 | (define (rope-lo r) 75 | (rope-size (rope-left r))) 76 | 77 | (define (rope-lo+hi r) 78 | (define lo (rope-lo r)) 79 | (values lo (+ lo (piece-size (rope-piece r))))) 80 | 81 | (define (find-position pos r) 82 | (if (rope-empty? r) 83 | (values 'here (zero? pos)) 84 | (let-values (((lo hi) (rope-lo+hi r))) 85 | (cond 86 | [(< pos lo) (values 'left pos)] 87 | [(< pos hi) (values 'here #t)] 88 | [else (values 'right (- pos hi))])))) 89 | 90 | (define (rope-index r) 91 | (match r 92 | [(rope-empty) #f] 93 | [_ (rope-index* r)])) 94 | 95 | (define (reindex r) 96 | (match-define (rope p rl rr _ _) r) 97 | (struct-copy rope r 98 | [size* (+ (rope-size rl) (rope-size rr) (piece-size p))] 99 | [index* (index-merge (index-merge (piece->index p) (rope-index rl)) (rope-index rr))])) 100 | 101 | (define (replace-left r n) (if (rope-empty? r) n (reindex (struct-copy rope r [left n])))) 102 | (define (replace-right r n) (if (rope-empty? r) n (reindex (struct-copy rope r [right n])))) 103 | (define (replace-both r rl rr) (reindex (struct-copy rope r [left rl] [right rr]))) 104 | 105 | (define (splay-to what r pos0) 106 | (define (ensure-found ok? r) 107 | (if (not ok?) 108 | (error what "Invalid position ~a" pos0) 109 | r)) 110 | (let walk ((r r) (pos0 pos0)) 111 | ;; zig: last. desired position is a direct (left/right) child of r. 112 | ;; zig-zig: desired position is within a (left-left/right-right) grandchild of r. 113 | ;; zig-zag: desired position is within a (left-right/right-left) grandchild of r. 114 | (match/values (find-position pos0 r) 115 | [('here ok?) (ensure-found ok? r)] 116 | [('left pos1) 117 | (define rl (rope-left r)) 118 | (match/values (find-position pos1 rl) 119 | [('here _) ;; zig 120 | (replace-right rl (replace-left r (and rl (rope-right rl))))] 121 | [('left pos2) ;; zig-zig 122 | (define rll (walk (rope-left rl) pos2)) 123 | (replace-right rll (replace-both rl 124 | (and rll (rope-right rll)) 125 | (replace-left r (rope-right rl))))] 126 | [('right pos2) ;; zig-zag 127 | (define rlr (walk (rope-right rl) pos2)) 128 | (replace-both rlr 129 | (replace-right rl (rope-left rlr)) 130 | (replace-left r (rope-right rlr)))])] 131 | [('right pos1) 132 | (define rr (rope-right r)) 133 | (match/values (find-position pos1 rr) 134 | [('here _) ;; zig 135 | (replace-left rr (replace-right r (and rr (rope-left rr))))] 136 | [('left pos2) ;; zig-zag 137 | (define rrl (walk (rope-left rr) pos2)) 138 | (replace-both rrl 139 | (replace-right r (rope-left rrl)) 140 | (replace-left rr (rope-right rrl)))] 141 | [('right pos2) ;; zig-zig 142 | (define rrr (walk (rope-right rr) pos2)) 143 | (replace-left rrr (replace-both rr 144 | (replace-right r (rope-left rr)) 145 | (and rrr (rope-left rrr))))])]))) 146 | 147 | (define (rope-seek r0 pos) 148 | (define r (splay-to 'rope-seek r0 pos)) 149 | (if (zero? pos) 150 | ;; Needed because splaying all the way left, when there is a 151 | ;; zero-sized piece at the very left, leaves us with that piece in the 152 | ;; left branch. 153 | (let hoist-left-piece ((r r)) 154 | (match r 155 | [(rope _ (? rope? rl) _ _ _) 156 | (hoist-left-piece (replace-right rl (replace-left r (rope-right rl))))] 157 | [_ r])) 158 | r)) 159 | 160 | (define (rope-split r0 position) 161 | (match (splay-to 'rope-split r0 position) 162 | [(rope-empty) (values (rope-empty) (rope-empty))] 163 | [(and r (rope p rl rr _ _)) 164 | ;; We know the position is in the root of r. 165 | (define-values (lo hi) (rope-lo+hi r)) 166 | (cond 167 | [(= position hi) 168 | ;; This only happens when position is right at the end of r0. 169 | ;; We check this condition *first* because (= position lo) 170 | ;; might also be true, in the case where (zero? (piece-size p)). 171 | (when (not (rope-empty? rr)) 172 | (error 'rope-split "Internal error: invariant failure at right: ~v / ~v" position r)) 173 | (define-values (left-p right-p) (piece-split p (- position lo))) 174 | (values (update-piece r left-p) 175 | (piece->rope right-p))] 176 | [(= position lo) 177 | (if (rope-empty? rl) 178 | (values rl r) 179 | (let* ((rl (splay-to 'rope-split rl (rope-size rl))) 180 | (rlp (rope-piece rl))) 181 | (define-values (left-p right-p) (piece-split rlp (piece-size rlp))) 182 | (values (update-piece rl left-p) 183 | (rope-append (piece->rope right-p) (replace-left r (rope-empty))))))] 184 | [else 185 | (define-values (left-p right-p) (piece-split p (- position lo))) 186 | (values (rope-append rl (piece->rope left-p) 'left) 187 | (rope-append (piece->rope right-p) rr))])])) 188 | 189 | (define (rope-append rl0 rr0 [bias 'right]) 190 | (cond [(rope-empty? rl0) rr0] 191 | [(rope-empty? rr0) rl0] 192 | [else 193 | (define rl (rope-seek rl0 (rope-size rl0))) 194 | (define rr (rope-seek rr0 0)) 195 | ;; Both rl's right and rr's left are (rope-empty). 196 | ;; Both rl's and rr's pieces are non `piece-empty?`. 197 | (piece-merge (rope-piece rl) 198 | (rope-piece rr) 199 | (lambda (p) (make-rope p (rope-left rl) (rope-right rr))) 200 | (lambda () 201 | (match bias 202 | ['right (replace-right rl rr)] 203 | ['left (replace-left rr rl)])))])) 204 | 205 | (define (rope-concat rs) 206 | (foldr rope-append (rope-empty) rs)) 207 | 208 | (define (subrope r0 [lo0 #f] [hi0 #f]) 209 | (define-values (lo hi) (compute-range-lo+hi lo0 hi0 (rope-size r0))) 210 | (define-values (_l mr) (rope-split r0 lo)) 211 | (define-values (m _r) (rope-split mr (- hi lo))) 212 | m) 213 | 214 | ;; Searches from pos (inclusive) in the direction indicated. 215 | (define (find-in-index* r forward? key start-pos) 216 | (define (search-here r offset start-pos) 217 | (match (piece-match (rope-piece r) forward? key start-pos) 218 | ['() #f] 219 | [(cons (cons pos value) _) (cons (+ offset (rope-lo r) pos) value)])) 220 | (define (search r offset start-pos) 221 | (and (not (rope-empty? r)) 222 | (index-contains? (rope-index r) key) 223 | (let-values (((lo hi) (rope-lo+hi r))) 224 | (if forward? 225 | (or (and (<= start-pos lo) (search (rope-left r) offset start-pos)) 226 | (and (<= start-pos hi) (search-here r offset (- start-pos lo))) 227 | (search (rope-right r) (+ offset hi) (- start-pos hi))) 228 | (or (and (>= start-pos hi) (search (rope-right r) (+ offset hi) (- start-pos hi))) 229 | (and (>= start-pos lo) (search-here r offset (- start-pos lo))) 230 | (search (rope-left r) offset start-pos)))))) 231 | (search r 0 start-pos)) 232 | 233 | (define (find-in-index r key 234 | #:forward? [forward? #t] 235 | #:position [start-pos (if forward? 0 (rope-size r))]) 236 | (find-in-index* r forward? key start-pos)) 237 | 238 | (define (find-pos-in-index r key 239 | #:forward? [forward? #t] 240 | #:position [start-pos (if forward? 0 (rope-size r))]) 241 | (cond [(find-in-index* r forward? key start-pos) => car] 242 | [else #f])) 243 | 244 | (define (find-all-in-index r key) 245 | (let walk ((r r) (offset 0) (acc (hash))) 246 | (if (or (rope-empty? r) (not (index-contains? (rope-index r) key))) 247 | acc 248 | (let-values (((lo hi) (rope-lo+hi r))) 249 | (let* ((acc (walk (rope-left r) offset acc)) 250 | (p (rope-piece r)) 251 | (acc (for/fold [(acc acc)] [(e (in-list (piece-match p #t key 0)))] 252 | (match-define (cons pos value) e) 253 | (hash-set acc (+ offset lo pos) value)))) 254 | (walk (rope-right r) (+ offset hi) acc)))))) 255 | 256 | (define (update-piece r p) 257 | (make-rope p (rope-left r) (rope-right r))) 258 | 259 | (define (rope-map r f) 260 | (let walk ((r r)) 261 | (if (rope-empty? r) 262 | r 263 | (rope-append (walk (rope-left r)) 264 | (rope-append (piece->rope (f (rope-piece r))) 265 | (walk (rope-right r))))))) 266 | 267 | (define (rope-map/key r key f) 268 | (let walk ((r r)) 269 | (if (or (rope-empty? r) (not (index-contains? (rope-index r) key))) 270 | r 271 | (rope-append (walk (rope-left r)) 272 | (rope-append (piece->rope (f (rope-piece r))) 273 | (walk (rope-right r))))))) 274 | 275 | (define (in-rope r #:forward? [forward? #t]) 276 | (if forward? 277 | (let loop ((r r)) 278 | (if (rope-empty? r) 279 | empty-stream 280 | (let ((r (rope-seek r 0))) 281 | (stream-cons (rope-piece r) (loop (rope-right r)))))) 282 | (let loop ((r r)) 283 | (if (rope-empty? r) 284 | empty-stream 285 | (let ((r (rope-seek r (rope-size r)))) 286 | (stream-cons (rope-piece r) (loop (rope-left r)))))))) 287 | 288 | (define (rope->piece-list r) 289 | (let walk ((r r) (tail '())) 290 | (match r 291 | [(rope-empty) tail] 292 | [(rope p rl rr _ _) (walk rl (cons p (walk rr tail)))]))) 293 | 294 | (define (rope->searchable-string r) 295 | (string-append* (map piece->searchable-string (rope->piece-list r)))) 296 | 297 | (define (rope->searchable-generator r #:forward? [forward? #t]) 298 | (define stack '()) 299 | (define text "") 300 | (define offset 0) 301 | (define count 0) 302 | (define (push! x) (when x (set! stack (cons x stack)))) 303 | (define (pop!) (and (pair? stack) (begin0 (car stack) (set! stack (cdr stack))))) 304 | (if forward? 305 | (let () 306 | (define (push-r! r) 307 | (when r 308 | (push! (rope-right r)) 309 | (push! (rope-piece r)) 310 | (push-r! (rope-left r)))) 311 | 312 | (push-r! r) 313 | (define i 0) 314 | (define (g) 315 | (if (< i count) 316 | (begin0 (string-ref text (+ offset i)) 317 | (set! i (+ i 1))) 318 | (match (pop!) 319 | [#f #f] 320 | [(? rope? r) 321 | (push-r! r) 322 | (g)] 323 | [(strand s o c) 324 | (set! text s) 325 | (set! offset o) 326 | (set! count c) 327 | (set! i 0) 328 | (g)] 329 | [p 330 | (set! text (piece->searchable-string p)) 331 | (set! offset 0) 332 | (set! count (string-length text)) 333 | (set! i 0) 334 | (g)]))) 335 | g) 336 | (let () 337 | (define (push-r! r) 338 | (when r 339 | (push! (rope-left r)) 340 | (push! (rope-piece r)) 341 | (push-r! (rope-right r)))) 342 | 343 | (push-r! r) 344 | (define i (- count 1)) 345 | (define (g) 346 | (if (>= i 0) 347 | (begin0 (string-ref text (+ offset i)) 348 | (set! i (- i 1))) 349 | (match (pop!) 350 | [#f #f] 351 | [(? rope? r) 352 | (push-r! r) 353 | (g)] 354 | [(strand s o c) 355 | (set! text s) 356 | (set! offset o) 357 | (set! count c) 358 | (set! i (- count 1)) 359 | (g)] 360 | [p 361 | (set! text (piece->searchable-string p)) 362 | (set! offset 0) 363 | (set! count (string-length text)) 364 | (set! i (- count 1)) 365 | (g)]))) 366 | g))) 367 | 368 | (define (rope->searchable-port r #:forward? [forward? #t] #:name [name ""]) 369 | (define buffer #"") 370 | (define offset 0) 371 | (define stack (list r)) 372 | (define (read-bytes! bs) 373 | (let retry () 374 | (define available (- (bytes-length buffer) offset)) 375 | (if (zero? available) 376 | (match stack 377 | ['() eof] 378 | [(cons (rope-empty) rest) 379 | (set! stack rest) 380 | (retry)] 381 | [(cons (? rope? r) rest) 382 | (set! stack 383 | (if forward? 384 | (list* (rope-left r) (rope-piece r) (rope-right r) rest) 385 | (list* (rope-right r) (rope-piece r) (rope-left r) rest))) 386 | (retry)] 387 | [(cons p rest) ;; p is a `piece?`, by elimination 388 | (define str (piece->searchable-string p)) 389 | (set! buffer (string->bytes/utf-8 (if forward? str (naive-string-reverse str)))) 390 | (set! offset 0) 391 | (set! stack rest) 392 | (retry)]) 393 | (let ((count (min available (bytes-length bs)))) 394 | (bytes-copy! bs 0 buffer offset (+ offset count)) 395 | (set! offset (+ offset count)) 396 | count)))) 397 | (make-input-port name 398 | read-bytes! 399 | #f 400 | void)) 401 | 402 | (module+ for-test 403 | (provide splay-to)) 404 | -------------------------------------------------------------------------------- /rmacs/rope/index.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; An Index is a user-maintained indexing structure associated with each Rope node. 3 | 4 | (provide gen:index 5 | index? 6 | index-merge 7 | index-rev-merge 8 | index-contains? 9 | define/generic ;; for convenience 10 | ) 11 | 12 | (require racket/generic) 13 | (require (only-in racket/bool false?)) 14 | 15 | (define-generics index 16 | (index-merge index index2) 17 | (index-rev-merge index index2) 18 | (index-contains? index key) 19 | #:defaults ([false? 20 | (define (index-merge i1 i2) i2) 21 | (define (index-rev-merge i2 i1) i1) 22 | (define (index-contains? i key) #f)])) 23 | -------------------------------------------------------------------------------- /rmacs/rope/piece.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; A Piece is a value carried by a particular Rope node. 3 | ;; Each Piece has a size associated with it - it takes up that many positions in the rope. 4 | 5 | (provide gen:piece 6 | piece? 7 | piece-size 8 | piece-empty? 9 | piece->searchable-string 10 | piece-match 11 | piece-split 12 | piece-merge 13 | piece-rev-merge 14 | piece->index 15 | 16 | *strand:glom-up-to* 17 | (struct-out strand) 18 | strand-empty 19 | strand-empty? 20 | string->strand 21 | strand->string 22 | substrand 23 | strand-equal? 24 | 25 | define/generic ;; for convenience 26 | ) 27 | 28 | (require racket/generic) 29 | (require racket/match) 30 | (require (only-in racket/bool false?)) 31 | (require "range.rkt") 32 | 33 | (define-generics piece 34 | (piece-size piece) 35 | (piece-empty? piece) 36 | (piece->searchable-string piece) ;; (string-length RESULT) === (piece-size piece) ! 37 | (piece-match piece forward? key offset) 38 | (piece-split piece offset) 39 | (piece-merge piece piece2 k-merge k-no-merge) 40 | (piece-rev-merge piece piece2 k-merge k-no-merge) 41 | (piece->index piece) 42 | #:defaults ([string? 43 | (define/generic rev-merge piece-rev-merge) 44 | (define (piece-size s) (string-length s)) 45 | (define (piece-empty? s) (zero? (string-length s))) 46 | (define (piece->searchable-string s) s) 47 | (define (piece-match s forward? key offset) '()) 48 | (define (piece-split s offset) (values (substrand s 0 offset) (substrand s offset))) 49 | (define (piece-merge s1 s2 k-merge k-no-merge) 50 | (if (string? s2) 51 | (if (<= (+ (string-length s1) (string-length s2)) *strand:glom-up-to*) 52 | (k-merge (string-append s1 s2)) 53 | (k-no-merge)) 54 | (rev-merge s2 s1 k-merge k-no-merge))) 55 | (define (piece-rev-merge s2 s1 k-merge k-no-merge) 56 | (k-no-merge)) 57 | (define (piece->index s) #f)] 58 | 59 | [false? 60 | (define (piece-size s) 0) 61 | (define (piece-empty? s) #t) 62 | (define (piece->searchable-string s) "") 63 | (define (piece-match s forward? key offset) '()) 64 | (define (piece-split s offset) (values #f #f)) 65 | (define (piece-merge s1 s2 k-merge k-no-merge) 66 | (k-merge s2)) 67 | (define (piece-rev-merge s2 s1 k-merge k-no-merge) 68 | (k-merge s2)) 69 | (define (piece->index s) #f)])) 70 | 71 | ;; TODO: measure to see if usage of *strand:glom-up-to* improves or worsens memory usage 72 | (define *strand:glom-up-to* 128) 73 | 74 | ;; A Strand is a (strand String Number Number), representing a 75 | ;; substring of a string. 76 | (struct strand (text offset length) #:transparent 77 | #:methods gen:piece 78 | [(define/generic rev-merge piece-rev-merge) 79 | (define (piece-size s) (strand-length s)) 80 | (define (piece-empty? s) (strand-empty? s)) 81 | (define (piece->searchable-string s) (strand->string s)) 82 | (define (piece-match s forward? key offset) '()) 83 | (define (piece-split s offset) (values (substrand s 0 offset) (substrand s offset))) 84 | (define (piece-merge s1 s2 k-merge k-no-merge) 85 | (cond [(string? s2) (strand-merge s1 (string->strand s2) k-merge k-no-merge)] 86 | [(strand? s2) (strand-merge s1 s2 k-merge k-no-merge)] 87 | [else (rev-merge s2 s1 k-merge k-no-merge)])) 88 | (define (piece-rev-merge s2 s1 k-merge k-no-merge) 89 | (cond [(string? s1) (strand-merge (string->strand s1) s2 k-merge k-no-merge)] 90 | [(strand? s1) (strand-merge s1 s2 k-merge k-no-merge)] 91 | [else (k-no-merge)])) 92 | (define (piece->index s) #f)]) 93 | 94 | (define (strand-empty) (strand "" 0 0)) 95 | (define (strand-empty? s) (zero? (strand-length s))) 96 | 97 | (define (string->strand s) (strand s 0 (string-length s))) 98 | 99 | (define (strand->string s) 100 | (match-define (strand text offset length) s) 101 | (if (= length (string-length text)) 102 | text 103 | (substring text offset (+ offset length)))) 104 | 105 | (define (substrand t0 [lo0 #f] [hi0 #f]) 106 | (define t (if (string? t0) (string->strand t0) t0)) 107 | (define-values (lo hi) (compute-range-lo+hi lo0 hi0 (strand-length t))) 108 | (strand (strand-text t) 109 | (+ (strand-offset t) lo) 110 | (- hi lo))) 111 | 112 | (define (strand-equal? t1 t2) 113 | (string=? (strand->string t1) 114 | (strand->string t2))) 115 | 116 | (define (strand-merge t1 t2 k-merge k-no-merge) 117 | (match-define (strand text1 offset1 count1) t1) 118 | (match-define (strand text2 offset2 count2) t2) 119 | (cond [(zero? count1) (k-merge t2)] 120 | [(zero? count2) (k-merge t1)] 121 | [(and (eq? text1 text2) 122 | (= (+ offset1 count1) offset2)) 123 | (if (and (= offset1 0) (= (+ offset2 count2) (string-length text1))) 124 | (k-merge text1) 125 | (k-merge (strand text1 offset1 (+ count1 count2))))] 126 | [(< (+ count1 count2) *strand:glom-up-to*) 127 | (k-merge (string-append (strand->string t1) (strand->string t2)))] 128 | [else (k-no-merge)])) 129 | -------------------------------------------------------------------------------- /rmacs/rope/range.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Pythonesque index computations including #f for default, and negative to count "from the end" 3 | 4 | (provide compute-range-index 5 | compute-range-lo+hi) 6 | 7 | (define (compute-range-index index default limit) 8 | (cond [(not index) default] 9 | [(zero? limit) 0] 10 | [else (max 0 (min limit (if (negative? index) (+ index limit) index)))])) 11 | 12 | (define (compute-range-lo+hi lo hi limit) 13 | (values (compute-range-index lo 0 limit) 14 | (compute-range-index hi limit limit))) 15 | -------------------------------------------------------------------------------- /rmacs/rope/string.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; String utilities 3 | 4 | (provide naive-string-reverse) 5 | 6 | (define (naive-string-reverse s) 7 | ;; Incredibly naive. Puts combining characters *before* the thing 8 | ;; they combine with. Hideously wrong. Still, it works for its 9 | ;; intended purpose: searching for a sequence of code points in 10 | ;; reverse order, where the *code points* are in the wrong order 11 | ;; too. 12 | (list->string (reverse (string->list s)))) 13 | -------------------------------------------------------------------------------- /rmacs/rope/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module+ test 4 | (require rackunit) 5 | 6 | (require "../rope.rkt") 7 | (require (submod "../rope.rkt" for-test)) 8 | (require "../mark.rkt") 9 | (require (submod "../mark.rkt" for-test)) 10 | (require "piece.rkt") 11 | (require "range.rkt") 12 | 13 | (check-equal? (rope-size (rope-empty)) 0) 14 | 15 | (define-syntax-rule (find-in-index/values arg ...) 16 | (match (find-in-index arg ...) 17 | [(cons p v) (values p v)] 18 | [#f (values #f #f)])) 19 | 20 | (define mtype1 (mark-type "Mark1" 'left)) 21 | (define mtype2 (mark-type "Mark2" 'right)) 22 | 23 | (define demo-rope 24 | (let ((r (lambda (s ms L R) 25 | (define m 26 | (for/fold [(r (piece->rope s))] [(e ms)] 27 | (match-define (list mtype pos val) e) 28 | (set-mark r mtype pos val))) 29 | (rope-append L (rope-append m R)))) 30 | (m1 (list (list mtype1 0 #t) (list mtype1 1 #t) (list mtype2 3 #t)))) 31 | ;; a b c d e f g h i j k l m n o p q r s t u 32 | ;; 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 2 2 33 | ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 34 | ;; * + * + * + * + * + * + * + 35 | ;; * * * * * * * 36 | ;; 37 | (r "jkl" 38 | m1 39 | (r "def" 40 | m1 41 | (r "abc" m1 (rope-empty) (rope-empty)) 42 | (r "ghi" m1 (rope-empty) (rope-empty))) 43 | (r "pqr" 44 | m1 45 | (r "mno" m1 (rope-empty) (rope-empty)) 46 | (r "stu" m1 (rope-empty) (rope-empty)))))) 47 | 48 | (check-equal? (rope->searchable-string demo-rope) "abcdefghijklmnopqrstu") 49 | (check-equal? (read-line (rope->searchable-port demo-rope)) "abcdefghijklmnopqrstu") 50 | 51 | (check-equal? (find-all-marks/type demo-rope mtype1) 52 | (for/hash ((i '(0 1 3 4 6 7 9 10 12 13 15 16 18 19))) (values i #t))) 53 | (check-equal? (find-all-marks/type demo-rope mtype2) 54 | (for/hash ((i '(3 6 9 12 15 18 21))) (values i #t))) 55 | 56 | (check-equal? (find-all-marks/type (clear-all-marks/type demo-rope mtype1) mtype1) 57 | (hash)) 58 | (check-equal? (find-all-marks/type (clear-all-marks/type demo-rope mtype2) mtype1) 59 | (for/hash ((i '(0 1 3 4 6 7 9 10 12 13 15 16 18 19))) (values i #t))) 60 | 61 | (let ((is '(0 1 3 4 6 7 9 10 12 13 15 16 18 19))) 62 | (for ((i is)) 63 | (define r (clear-mark demo-rope mtype1 i)) 64 | (check-equal? (rope->searchable-string r) "abcdefghijklmnopqrstu") 65 | (check-equal? (find-all-marks/type r mtype1) 66 | (for/hash ((j (remove i is))) (values j #t))))) 67 | 68 | (let ((is '(3 6 9 12 15 18 21))) 69 | (for ((i is)) 70 | (define r (clear-mark demo-rope mtype2 i)) 71 | (check-equal? (find-all-marks/type r mtype2) 72 | (for/hash ((j (remove i is))) (values j #t))))) 73 | 74 | (let-values (((l r) (rope-split demo-rope 3))) 75 | (check-equal? (find-all-marks/type l mtype2) (hash)) 76 | (check-equal? (find-all-marks/type r mtype2) 77 | (for/hash ((i '(0 3 6 9 12 15 18))) (values i #t)))) 78 | 79 | (let-values (((l r) (rope-split demo-rope 3))) 80 | (check-equal? (find-all-marks/type l mtype1) 81 | (for/hash ((i '(0 1 3))) (values i #t))) 82 | (check-equal? (find-all-marks/type r mtype1) 83 | (for/hash ((i '(1 3 4 6 7 9 10 12 13 15 16))) (values i #t)))) 84 | 85 | (define (test-with-pieces string-pieces) 86 | (define rope-pieces (map piece->rope string-pieces)) 87 | (define text (string-append* string-pieces)) 88 | (check-equal? (rope->searchable-string (car rope-pieces)) (car string-pieces)) 89 | (check-equal? (rope->searchable-string (rope-concat rope-pieces)) text) 90 | (check-equal? (rope-size (rope-concat rope-pieces)) (string-length text)) 91 | 92 | (check-eq? (rope-append (rope-empty) (car rope-pieces)) (car rope-pieces)) 93 | (check-eq? (rope-append (car rope-pieces) (rope-empty)) (car rope-pieces)) 94 | 95 | (let loop ((n 1000) (r0 (rope-concat rope-pieces))) 96 | (when (positive? n) 97 | (define pos (random (+ (rope-size r0) 1))) 98 | ;; (pretty-print (list pos r0)) 99 | (define r (splay-to 'test-with-pieces r0 pos)) 100 | (check-equal? (rope->searchable-string r) text) 101 | (loop (- n 1) r))) 102 | 103 | (let*-values (((r) (set-mark (rope-concat rope-pieces) mtype1 9 "original")) 104 | ((_) (check-equal? (rope->searchable-string r) text)) 105 | ((pos val) (find-in-index/values r mtype1)) 106 | ((_) (check-equal? pos 9)) 107 | ((_) (check-equal? val "original")) 108 | ((r) (clear-mark r mtype1 pos)) 109 | ((_) (check-equal? (find-all-marks/type r mtype1) (hash))) 110 | ((pos val) (find-in-index/values r mtype1)) 111 | ((_) (check-false pos)) 112 | ((_) (check-false val)) 113 | ((r) (set-mark r mtype1 9 "second")) 114 | ((pos val) (find-in-index/values r mtype1)) 115 | ((_) (check-equal? pos 9)) 116 | ((_) (check-equal? val "second")) 117 | ((r) (set-mark r mtype1 6 "first")) 118 | ((r) (set-mark r mtype2 6 "third")) 119 | ((_) (check-equal? (find-all-marks/type r mtype1) (hash 6 "first" 9 "second"))) 120 | ((_) (check-equal? (find-all-marks/type r mtype2) (hash 6 "third"))) 121 | ((pos val) (find-in-index/values r mtype1 #:forward? #f)) 122 | ((_) (check-equal? pos 9)) 123 | ((_) (check-equal? val "second")) 124 | ((pos val) (find-in-index/values r mtype1)) 125 | ((_) (check-equal? pos 6)) 126 | ((_) (check-equal? val "first")) 127 | ((l r) (rope-split r pos)) 128 | ((_) (check-equal? (find-all-marks/type r mtype1) (hash 3 "second"))) 129 | ((_) (check-equal? (find-all-marks/type l mtype1) (hash 6 "first"))) 130 | ((_) (check-equal? (find-all-marks/type r mtype2) (hash 0 "third"))) 131 | ((_) (check-equal? (find-all-marks/type l mtype2) (hash))) 132 | ((_) (check-equal? (rope->searchable-string l) (substring text 0 6))) 133 | ((_) (check-equal? (rope->searchable-string r) (substring text 6 (string-length text)))) 134 | ((_) (check-equal? (rope-index l) (marks-index (seteq mtype1)))) 135 | ((_) (check-equal? (rope-index r) (marks-index (seteq mtype1 mtype2)))) 136 | ((l r) (rope-split r 3)) 137 | ((_) (check-equal? (find-all-marks/type r mtype1) (hash))) 138 | ((_) (check-equal? (find-all-marks/type l mtype1) (hash 3 "second"))) 139 | ((_) (check-equal? (find-all-marks/type r mtype2) (hash))) 140 | ((_) (check-equal? (find-all-marks/type l mtype2) (hash 0 "third"))) 141 | ((_) (check-equal? (rope->searchable-string l) (substring text 6 9))) 142 | ((_) (check-equal? (rope->searchable-string r) (substring text 9 (string-length text))))) 143 | (void))) 144 | 145 | (define prejudice-pieces 146 | (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" 147 | "\n" 148 | "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" 149 | "\n" 150 | "``My dear Mr. Bennet,'' said his lady to him one day, ``have you heard that Netherfield Park is let at last?''\n" 151 | "\n" 152 | "Mr. Bennet replied that he had not.\n")) 153 | 154 | (define (atomize-pieces pieces) 155 | (map string (string->list (string-append* pieces)))) 156 | 157 | (test-with-pieces (list "hello" ", " "world")) 158 | (test-with-pieces prejudice-pieces) 159 | (test-with-pieces (atomize-pieces prejudice-pieces)) 160 | 161 | (check-equal? (call-with-values (lambda () (rope-split (rope-empty) 0)) list) 162 | (list (rope-empty) (rope-empty))) 163 | 164 | (check-equal? (map rope->searchable-string 165 | (call-with-values (lambda () (rope-split (piece->rope "abc") 0)) list)) 166 | (list "" "abc")) 167 | (check-equal? (map rope->searchable-string 168 | (call-with-values (lambda () (rope-split (piece->rope "abc") 2)) list)) 169 | (list "ab" "c")) 170 | (check-equal? (map rope->searchable-string 171 | (call-with-values (lambda () (rope-split (piece->rope "abc") 3)) list)) 172 | (list "abc" "")) 173 | 174 | (check-equal? (map (lambda (i) (compute-range-index i 'default 10)) 175 | (list 0 10 3 -1 -2 11 12 -8 -9 -10 -11 -12)) 176 | (list 0 10 3 9 8 10 10 2 1 0 0 0)) 177 | 178 | (let* ((r (rope-append (piece->rope (make-string 10 #\a)) 179 | (piece->rope (make-string (* 2 *strand:glom-up-to*) #\z)))) 180 | (expected-size (+ 10 (* 2 *strand:glom-up-to*))) 181 | (_ (check-equal? (rope-size r) expected-size)) 182 | (r (set-mark r mtype1 (rope-size r) #t)) 183 | (r (splay-to 'testing r 0)) 184 | (pos (find-pos-in-index r mtype1))) 185 | (check-equal? pos expected-size)) 186 | 187 | (let*-values (((r) (piece->rope "hello")) 188 | ((r) (set-mark r mtype2 (rope-size r) #t)) 189 | ((l r) (rope-split r (find-pos-in-index r mtype2))) 190 | ((_) (check-equal? (rope->searchable-string l) "hello")) 191 | ((_) (check-equal? (rope->searchable-string r) "")) 192 | ((_) (check-equal? (rope-index l) #f)) 193 | ((_) (check-equal? (rope-index r) (marks-index (seteq mtype2))))) 194 | (void)) 195 | 196 | (let*-values (((xs) (make-string 128 #\x)) 197 | ((r) (piece->rope (string-append "hello " xs))) 198 | ((r) (set-mark r mtype2 3 #t)) 199 | ((l mr) (rope-split r (find-pos-in-index r mtype2))) 200 | ((m r) (rope-split mr 1)) 201 | ((_) (check-equal? (rope->searchable-string l) "hel")) 202 | ((_) (check-equal? (rope->searchable-string m) "l")) 203 | ((_) (check-equal? (rope->searchable-string r) (string-append "o " xs))) 204 | ((_) (check-equal? (rope-index l) #f)) 205 | ((_) (check-equal? (rope-index m) (marks-index (seteq mtype2)))) 206 | ((_) (check-equal? (rope-index r) #f)) 207 | ((new-m) (set-mark (rope-empty) mtype2 0 #t)) 208 | ((r) (rope-append (rope-append l new-m) r)) 209 | ((_) (check-equal? (rope->searchable-string r) (string-append "helo " xs))) 210 | ((_) (check-equal? (find-pos-in-index r mtype2) 3)) 211 | ((r) (clear-mark r mtype2 (find-pos-in-index r mtype2))) 212 | ((_) (check-equal? (find-pos-in-index r mtype2) #f))) 213 | (void)) 214 | 215 | (check-equal? (read (rope->searchable-port (piece->rope "(a b c)"))) '(a b c)) 216 | (check-equal? (read-line (rope->searchable-port (piece->rope "(a b c)") #:forward? #f)) ")c b a(") 217 | (check-true (eof-object? (read (rope->searchable-port (rope-empty))))) 218 | ) 219 | 220 | -------------------------------------------------------------------------------- /rmacs/search.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Knuth-Morris-Pratt string & rope search. 3 | 4 | (provide search-generator 5 | search-string 6 | search-rope 7 | 8 | ;; Warning: these don't act like `findf`, quite. 9 | findf-in-generator 10 | findf-in-rope) 11 | 12 | (require racket/set) 13 | (require racket/match) 14 | (require "rope.rkt") 15 | (require "rope/string.rkt") 16 | 17 | (define (table pattern) 18 | (define limit (- (string-length pattern) 1)) 19 | (if (positive? limit) 20 | (let ((t (make-vector limit))) 21 | (vector-set! t 0 0) 22 | (let loop ((pos 1) (candidate 0)) 23 | (cond 24 | [(= pos limit) 25 | t] 26 | [(equal? (string-ref pattern pos) 27 | (string-ref pattern candidate)) 28 | (vector-set! t pos (+ candidate 1)) 29 | (loop (+ pos 1) 30 | (+ candidate 1))] 31 | [(> candidate 0) 32 | (loop pos 33 | (vector-ref t candidate))] 34 | [else 35 | (vector-set! t pos 0) 36 | (loop (+ pos 1) 37 | 0)]))) 38 | #f)) 39 | 40 | ;; String (Generator Char) -> (Option Index) 41 | (define (search-generator needle haystack) 42 | (define t (table needle)) 43 | (define cache #f) 44 | (define (advance!) 45 | (define next (haystack)) 46 | (set! cache (and (char? next) next))) 47 | (advance!) 48 | (let loop ((m 0) (i 0)) 49 | (cond 50 | [(not cache) 51 | #f] 52 | [(equal? (string-ref needle i) cache) 53 | (if (= i (- (string-length needle) 1)) 54 | m 55 | (begin (advance!) 56 | (loop m (+ i 1))))] 57 | [(> i 0) 58 | (define ti (vector-ref t (- i 1))) 59 | (loop (- (+ m i) ti) ti)] 60 | [else 61 | (advance!) 62 | (loop (+ m 1) i)]))) 63 | 64 | ;; String String -> (Option Index) 65 | (define (search-string needle haystack) 66 | (define t (table needle)) 67 | (let loop ((m 0) (i 0)) 68 | (cond 69 | [(= (+ m i) (string-length haystack)) 70 | #f] 71 | [(equal? (string-ref needle i) (string-ref haystack (+ m i))) 72 | (if (= i (- (string-length needle) 1)) 73 | m 74 | (loop m (+ i 1)))] 75 | [(> i 0) 76 | (define ti (vector-ref t (- i 1))) 77 | (loop (- (+ m i) ti) ti)] 78 | [else 79 | (loop (+ m 1) i)]))) 80 | 81 | ;; String Rope -> (Option Index) 82 | (define (search-rope needle haystack #:forward? [forward? #t]) 83 | (if forward? 84 | (search-generator needle (rope->searchable-generator haystack)) 85 | (let ((reversed-result (search-generator (naive-string-reverse needle) 86 | (rope->searchable-generator haystack #:forward? #f)))) 87 | (and reversed-result (- (rope-size haystack) reversed-result (string-length needle)))))) 88 | 89 | ;; Returns the index where `f` first yields `#t`, OR the total number of elements in `gen`. 90 | (define (findf-in-generator f gen) 91 | (let loop ((count 0)) 92 | (match (gen) 93 | [(? char? c) 94 | (if (f c) 95 | count 96 | (loop (+ count 1)))] 97 | [_ count]))) 98 | 99 | (define (findf-in-rope f r #:forward? [forward? #t]) 100 | (if forward? 101 | (findf-in-generator f (rope->searchable-generator r)) 102 | (- (rope-size r) (findf-in-generator f (rope->searchable-generator r #:forward? #f))))) 103 | 104 | (module+ test 105 | (require rackunit) 106 | (require racket/generator) 107 | (check-equal? (table "ABCDABD") 108 | (vector 0 0 0 0 1 2)) 109 | (check-equal? (table "PARTICIPATE IN PARACHUTE") 110 | (vector 0 0 0 0 0 0 0 1 2 0 0 0 0 0 0 1 2 3 0 0 0 0 0)) 111 | (check-equal? (search-string "ABCDABD" "ABC ABCDAB ABCDABCDABDE") 15) 112 | (check-equal? (search-string "AAAA" "AAABAAABAAABAAABAAAB") #f) 113 | 114 | (check-equal? (search-generator "ABCDABD" (sequence->generator "ABC ABCDAB ABCDABCDABDE")) 15) 115 | (check-equal? (search-generator "AAAA" (sequence->generator "AAABAAABAAABAAABAAAB")) #f) 116 | 117 | (define prejudice-rope 118 | (rope-concat 119 | (map piece->rope 120 | (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" 121 | "\n" 122 | "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" 123 | "\n" 124 | "``My dear Mr. Bennet,'' said his lady to him one day, ``have you heard that Netherfield Park is let at last?''\n" 125 | "\n" 126 | "Mr. Bennet replied that he had not.\n")))) 127 | 128 | (check-equal? (search-rope "man" prejudice-rope) 54) 129 | (check-equal? (search-rope "man" prejudice-rope #:forward? #f) 171) 130 | (check-equal? (search-rope "man in" prejudice-rope) 54) 131 | (check-equal? (search-rope "man may" prejudice-rope) 171) 132 | (check-equal? (search-rope "man may" prejudice-rope #:forward? #f) 171) 133 | (check-equal? (search-rope "xylophone" prejudice-rope) #f) 134 | (check-equal? (search-rope "xylophone" prejudice-rope #:forward? #f) #f) 135 | 136 | (let ((g (rope->searchable-generator prejudice-rope))) 137 | (check-equal? (search-generator "man may " g) 171) 138 | (check-equal? (g) #\b) 139 | (check-equal? (g) #\e)) 140 | 141 | (let ((g (rope->searchable-generator prejudice-rope))) 142 | (check-equal? (search-generator "xylophone" g) #f) 143 | (check-equal? (g) #f) 144 | (check-equal? (g) #f)) 145 | 146 | (define (find-in-rope delims r #:forward? [forward? #t]) 147 | (define chs (list->set (string->list delims))) 148 | (findf-in-rope (lambda (c) (set-member? chs c)) r #:forward? forward?)) 149 | 150 | (check-equal? (find-in-rope "\n" prejudice-rope) 116) 151 | (check-equal? (find-in-rope "at" prejudice-rope) 1) 152 | (check-equal? (find-in-rope "z" prejudice-rope) (rope-size prejudice-rope)) 153 | (check-equal? (find-in-rope "\n" prejudice-rope #:forward? #f) (rope-size prejudice-rope)) 154 | (check-equal? (find-in-rope "at" prejudice-rope #:forward? #f) (- (rope-size prejudice-rope) 2)) 155 | (check-equal? (find-in-rope "z" prejudice-rope #:forward? #f) 0)) 156 | -------------------------------------------------------------------------------- /rmacs/strings.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; String utilities :-( 3 | 4 | (provide string-prefix?) 5 | 6 | (define (string-prefix? a b [string=? string=?]) 7 | (define a-len (string-length a)) 8 | (and (>= (string-length b) a-len) 9 | (string=? (substring b 0 a-len) a))) 10 | 11 | (module+ test 12 | (require rackunit) 13 | (check-true (string-prefix? "aaa" "aaaa")) 14 | (check-false (string-prefix? "aaaa" "aaa")) 15 | (check-false (string-prefix? "a" "z")) 16 | (check-false (string-prefix? "z" "a")) 17 | (check-true (string-prefix? "a" "a")) 18 | ) 19 | -------------------------------------------------------------------------------- /rmacs/syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Syntax utilities :-( 3 | 4 | (provide build-name) 5 | 6 | (define (build-name id . parts) 7 | (datum->syntax id 8 | (string->symbol 9 | (apply string-append (map (lambda (p) 10 | (if (syntax? p) 11 | (symbol->string (syntax-e p)) 12 | p)) 13 | parts))) 14 | id)) 15 | -------------------------------------------------------------------------------- /rmacs/timing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide time* 4 | profile*) 5 | 6 | (require profile) 7 | 8 | (define-syntax-rule (time* label exp ...) 9 | (let ((saved-output-port (current-output-port))) 10 | (parameterize ((current-output-port (current-error-port))) 11 | (time 12 | (begin0 (parameterize ((current-output-port saved-output-port)) exp ...) 13 | (printf "time* ~v: " label)))))) 14 | 15 | (define-syntax-rule (profile* exp ...) 16 | (let ((saved-output-port (current-output-port))) 17 | (parameterize ((current-output-port (current-error-port))) 18 | (profile (parameterize ((current-output-port saved-output-port)) exp ...))))) 19 | -------------------------------------------------------------------------------- /rmacs/topsort.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide topsort) 4 | 5 | (require racket/match) 6 | 7 | (define (topsort edges 8 | #:comparison [comparison equal?]) 9 | (define hash-ctor (cond [(eq? comparison equal?) hash] 10 | [(eq? comparison eq?) hasheq] 11 | [else (error 'topsort "Invalid comparison ~v" comparison)])) 12 | (define-values (fwd rev) 13 | (for/fold [(fwd (hash-ctor)) (rev (hash-ctor))] 14 | [(edge edges)] 15 | (match-define (list source target) edge) 16 | (values (hash-set fwd source (hash-set (hash-ref fwd source hash-ctor) target #t)) 17 | (hash-set rev target (hash-set (hash-ref rev target hash-ctor) source #t))))) 18 | (define roots (for/fold [(roots (hash-ctor))] 19 | [(source (in-hash-keys fwd))] 20 | (if (hash-has-key? rev source) 21 | roots 22 | (hash-set roots source #t)))) 23 | 24 | (if (hash-empty? roots) 25 | (if (and (hash-empty? fwd) (hash-empty? rev)) 26 | '() ;; no nodes at all 27 | #f) ;; no nodes without incoming edges -> cycle 28 | (let/ec return 29 | (define seen (hash-ctor)) 30 | (define busy (hash-ctor)) 31 | (define acc '()) 32 | 33 | (define (visit-nodes nodes) 34 | (for ((n nodes)) 35 | (when (hash-has-key? busy n) (return #f)) ;; cycle 36 | (when (not (hash-has-key? seen n)) 37 | (set! busy (hash-set busy n #t)) 38 | (visit-nodes (hash-keys (hash-ref fwd n hash-ctor))) 39 | (set! seen (hash-set seen n #t)) 40 | (set! busy (hash-remove busy n)) 41 | (set! acc (cons n acc))))) 42 | 43 | (visit-nodes (hash-keys roots)) 44 | acc))) 45 | 46 | (module+ test 47 | (require rackunit) 48 | (check-equal? (topsort '()) '()) 49 | (check-equal? (topsort '((1 1))) #f) 50 | (check-equal? (topsort '((1 0) (0 1))) #f) 51 | (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 0) (0 1))) #f) 52 | (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 1) (0 1))) #f) 53 | 54 | (define (topsort-output-correct? input) 55 | (define output (topsort input)) 56 | (for/and [(edge (in-list input))] 57 | (match-define (list src dst) edge) 58 | (positive? (- (length (member src output)) 59 | (length (member dst output)))))) 60 | 61 | (check-true (topsort-output-correct? '((1 2) (1 3) (3 2) (3 4) (0 1)))) 62 | ) 63 | -------------------------------------------------------------------------------- /rmacs/window.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (except-out (struct-out window) window set-window-buffer!) 4 | (rename-out [set-window-buffer!* set-window-buffer!]) 5 | make-window 6 | window-editor 7 | window-command 8 | window-move-to! 9 | position-visible? 10 | window-available-line-count 11 | ) 12 | 13 | (require racket/match) 14 | 15 | (require "buffer.rkt") 16 | (require "rope.rkt") 17 | (require "mark.rkt") 18 | 19 | (struct window (id ;; Symbol 20 | top ;; MarkType 21 | bottom ;; MarkType 22 | point ;; MarkType 23 | [buffer #:mutable] ;; (Option Buffer) 24 | [status-line? #:mutable] ;; Boolean 25 | [width #:mutable] ;; Option Nat -- set by layout-windows 26 | [height #:mutable] ;; Option Nat -- set by layout-windows 27 | ) #:prefab) 28 | 29 | (define (make-window initial-buffer #:point [initial-point-or-mark point-mark]) 30 | (define id (gensym 'window)) 31 | (define w (window id 32 | (mark-type (buffer-mark-type 'top id #f) 'left) 33 | (mark-type (buffer-mark-type 'bottom id #f) 'left) 34 | (mark-type (buffer-mark-type 'point id #t) 'right) 35 | #f 36 | #t 37 | #f 38 | #f)) 39 | (set-window-buffer!* w initial-buffer initial-point-or-mark) ;; sets initial marks 40 | w) 41 | 42 | (define (window-editor w) 43 | (and (window-buffer w) 44 | (buffer-editor (window-buffer w)))) 45 | 46 | (define (set-window-buffer!* win new [point-or-mark point-mark]) 47 | (define old (window-buffer win)) 48 | (when old 49 | (let ((p (buffer-pos* old (window-point win)))) 50 | (when p (buffer-mark! old point-mark p))) 51 | (buffer-clear-mark! old (window-top win)) 52 | (buffer-clear-mark! old (window-bottom win)) 53 | (buffer-clear-mark! old (window-point win))) 54 | (set-window-buffer! win new) 55 | (when new 56 | (buffer-mark! new (window-point win) (or (buffer-pos* new point-or-mark) 0))) 57 | (void)) 58 | 59 | (define (window-command selector window 60 | #:args args 61 | #:editor [editor #f] 62 | #:keyseq [keyseq #f] 63 | #:prefix-arg [prefix-arg '#:default]) 64 | (command selector (window-buffer window) 65 | #:args args 66 | #:window window 67 | #:editor editor 68 | #:keyseq keyseq 69 | #:prefix-arg prefix-arg)) 70 | 71 | (define (window-move-to! win pos) 72 | (buffer-mark! (window-buffer win) (window-point win) pos) 73 | win) 74 | 75 | ;; NOTE: relies on the frame being accurate, so it is not valid to 76 | ;; rely on the results of this call if any change has been made to the 77 | ;; buffer since the last re-framing (i.e. usually the last redisplay). 78 | (define (position-visible? win pos) 79 | (define t (buffer-mark-pos* (window-buffer win) (window-top win))) 80 | (define b (buffer-mark-pos* (window-buffer win) (window-bottom win))) 81 | (and t b (<= t pos b))) 82 | 83 | (define (window-available-line-count win) 84 | (- (window-height win) (if (window-status-line? win) 1 0))) 85 | -------------------------------------------------------------------------------- /rmacs/wrap.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (struct-out wrap) 4 | wrap-line-count 5 | basic-wrap 6 | buffer-lines-reverse/wrap 7 | buffer-lines-forward/wrap) 8 | 9 | (require "buffer.rkt") 10 | 11 | (struct wrap (width ;; Nat 12 | points ;; (List Nat) 13 | eol-pos ;; Nat 14 | ) #:prefab) 15 | 16 | ;; Soft-wraps the line starting at sol-pos to the given width. 17 | (define (basic-wrap buf sol-pos width) 18 | (define eol-pos (buffer-end-of-line buf sol-pos)) 19 | (let loop ((soft-sol-pos sol-pos) 20 | (points '())) 21 | (define next-sol (buffer-closest-pos-for-column buf soft-sol-pos 0 width)) 22 | (if (< next-sol eol-pos) 23 | (loop next-sol (cons next-sol points)) 24 | (wrap width (reverse points) eol-pos)))) 25 | 26 | (define (wrap-line-count w) 27 | (+ 1 (length (wrap-points w)))) 28 | 29 | (define (buffer-lines-reverse/wrap buf pos-or-mtype wrap-fn width) 30 | (define start-pos (buffer-pos buf pos-or-mtype)) 31 | (define k 32 | (lambda () 33 | (let hard-break ((eol-pos (buffer-end-of-line buf start-pos))) 34 | (if (< eol-pos 0) 35 | (values #f #f) 36 | (let* ((sol-pos (buffer-start-of-line buf eol-pos)) 37 | (w (wrap-fn buf sol-pos width))) 38 | (let soft-break ((eol eol-pos) (ps (reverse (wrap-points w)))) 39 | (if (null? ps) 40 | (begin (set! k (lambda () (hard-break (- sol-pos 1)))) 41 | (values sol-pos eol)) 42 | (begin (set! k (lambda () (soft-break (car ps) (cdr ps)))) 43 | (if (<= (car ps) start-pos) 44 | (values (car ps) eol) 45 | (k)))))))))) 46 | (lambda () (k))) 47 | 48 | (define (buffer-lines-forward/wrap buf pos-or-mtype wrap-fn width) 49 | (define start-pos (buffer-pos buf pos-or-mtype)) 50 | (define k 51 | (lambda () 52 | (let hard-break ((sol-pos (buffer-start-of-line buf start-pos))) 53 | (if (> sol-pos (buffer-size buf)) 54 | (values #f #f) 55 | (let* ((w (wrap-fn buf sol-pos width))) 56 | (let soft-break ((sol sol-pos) (ps (wrap-points w))) 57 | (if (null? ps) 58 | (begin (set! k (lambda () (hard-break (+ (wrap-eol-pos w) 1)))) 59 | (values sol (wrap-eol-pos w))) 60 | (begin (set! k (lambda () (soft-break (car ps) (cdr ps)))) 61 | (if (> (car ps) start-pos) 62 | (values sol (car ps)) 63 | (k)))))))))) 64 | (lambda () (k))) 65 | --------------------------------------------------------------------------------