├── .gitignore ├── README.md ├── change.rkt ├── common-utils.rkt ├── controller-test.rkt ├── controller-test1.rkt ├── controller-test2.rkt ├── controller-test3.rkt ├── controller.rkt ├── core.rkt ├── diff-manager.rkt ├── diff-utils.rkt ├── diff.rkt ├── draw-line.rkt ├── gui.rkt ├── illead.txt ├── insert-utils.rkt ├── key-event-key.rkt ├── macro-recorder.rkt ├── match-paren.rkt ├── mode-base.rkt ├── mode-utils.rkt ├── mode.rkt ├── move.rkt ├── operators.rkt ├── params.rkt ├── reg-manager.rkt ├── scope.rkt ├── search.rkt ├── substitude.rkt └── wrapped-move-scope.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | editor 2 | ====== 3 | 4 | Vim style editor written in Racket 5 | 6 | ## Objective 7 | As the backend of https://github.com/BowenFu/drracket-vim-tool. 8 | 9 | ## Roadmap 10 | 11 | These are the big Vim features, put generally in the order in which we plan to implement them. 12 | 13 | | Status | Command | 14 | | ------------------ | ---------------------- | 15 | | [x] | Normal Mode | 16 | | [x] | Insert Mode | 17 | | [x] | Visual Mode | 18 | | [x] | Visual Line Mode | 19 | | [x] | Number Prefixes | 20 | | [x] | . Operator | 21 | | [x] | Searching with / and ? | 22 | | [x] | Undo/Redo | 23 | | [x] | Marks | 24 | | [x] | Text Objects | 25 | | [x] | Visual Block Mode | 26 | | [x] | Replace Mode | 27 | | [x] | Macros | 28 | | [ ] | Buffer/Window/Tab | 29 | | [ ] | Command Remapping | 30 | 31 | Now follows an exhaustive list of every known Vim command that we could find. 32 | 33 | ## Left-right motions 34 | 35 | | Status | Command | Description | 36 | | ------------------ | -------------- | ------------------------------------------------------------------------------ | 37 | | [x] | :1234: h | left (also: CTRL-H, BS, or Left key) | 38 | | [x] | :1234: l | right (also: Space or Right key) | 39 | | [x] | 0 | to first character in the line (also: Home key) | 40 | | [x] | ^ | to first non-blank character in the line | 41 | | [x] | :1234: \$ | to the last character in the line (N-1 lines lower) (also: End key) | 42 | | [x] | :1234: \| | to column N (default: 1) | 43 | | [x] | :1234: f{char} | to the Nth occurrence of {char} to the right | 44 | | [x] | :1234: F{char} | to the Nth occurrence of {char} to the left | 45 | | [x] | :1234: t{char} | till before the Nth occurrence of {char} to the right | 46 | | [x] | :1234: T{char} | till before the Nth occurrence of {char} to the left | 47 | | [x] | :1234: ; | repeat the last "f", "F", "t", or "T" N times | 48 | | [x] | :1234: , | repeat the last "f", "F", "t", or "T" N times in opposite direction | 49 | | [ ] | g0 | to first character in screen line (differs from "0" when lines wrap) | 50 | | [ ] | g^ | to first non-blank character in screen line (differs from "^" when lines wrap) | 51 | | [ ] | :1234: g\$ | to last character in screen line (differs from "\$" when lines wrap) | 52 | | [ ] | gm | to middle of the screen line | 53 | 54 | ## Up-down motions 55 | 56 | | Status | Command | Description | 57 | | ------------------ | --------- | ----------------------------------------------------------------------------------------- | 58 | | [x] | :1234: k | up N lines (also: CTRL-P and Up) | 59 | | [x] | :1234: j | down N lines (also: CTRL-J, CTRL-N, NL, and Down) | 60 | | [x] | :1234: G | goto line N (default: last line), on the first non-blank character | 61 | | [x] | :1234: gg | goto line N (default: first line), on the first non-blank character | 62 | | [x] | :1234: % | goto line N percentage down in the file; N must be given, otherwise it is the `%` command | 63 | | [ ] | :1234: gk | up N screen lines (differs from "k" when line wraps) | 64 | | [ ] | :1234: gj | down N screen lines (differs from "j" when line wraps) | 65 | | [ ] | :1234: - | up N lines, on the first non-blank character | 66 | | [ ] | :1234: + | down N lines, on the first non-blank character (also: CTRL-M and CR) | 67 | | [ ] | :1234: \_ | down N-1 lines, on the first non-blank character | 68 | 69 | ## Text object motions 70 | 71 | | Status | Command | Description | 72 | | ------------------ | ---------- | ----------------------------------------------------------- | 73 | | [x] | :1234: w | N words forward | 74 | | [x] | :1234: W | N blank-separated WORDs forward | 75 | | [x] | :1234: e | N words forward to the end of the Nth word | 76 | | [x] | :1234: E | N words forward to the end of the Nth blank-separated WORD | 77 | | [x] | :1234: b | N words backward | 78 | | [x] | :1234: B | N blank-separated WORDs backward | 79 | | [ ] | :1234: ge | N words backward to the end of the Nth word | 80 | | [ ] | :1234: gE | N words backward to the end of the Nth blank-separated WORD | 81 | | [ ] | :1234: ) | N sentences forward | 82 | | [ ] | :1234: ( | N sentences backward | 83 | | [ ] | :1234: } | N paragraphs forward | 84 | | [ ] | :1234: { | N paragraphs backward | 85 | | [ ] | :1234: ]] | N sections forward, at start of section | 86 | | [ ] | :1234: [[ | N sections backward, at start of section | 87 | | [ ] | :1234: ][ | N sections forward, at end of section | 88 | | [ ] | :1234: [] | N sections backward, at end of section | 89 | | [ ] | :1234: [( | N times back to unclosed '(' | 90 | | [ ] | :1234: [{ | N times back to unclosed '{' | 91 | | [ ] | :1234: ]) | N times forward to unclosed ')' | 92 | | [ ] | :1234: ]} | N times forward to unclosed '}' | 93 | 94 | ## Pattern searches 95 | 96 | | Status | Command | Description | 97 | | --- | ---------------------------------- | ------------------------------------------------------ | 98 | | [x] | :1234: `/{pattern}[/[offset]]` | search forward for the Nth occurrence of {pattern} | 99 | | [x] | :1234: `?{pattern}[?[offset]]` | search backward for the Nth occurrence of {pattern} | 100 | | [x] | :1234: `/` | repeat last search, in the forward direction | 101 | | [x] | :1234: `?` | repeat last search, in the backward direction | 102 | | [x] | :1234: n | repeat last search | 103 | | [x] | :1234: N | repeat last search, in opposite direction | 104 | | [x] | :1234: \* | search forward for the identifier under the cursor | 105 | | [x] | :1234: # | search backward for the identifier under the cursor | 106 | | [ ] | :1234: g\* | like "\*", but also find partial matches | 107 | | [ ] | :1234: g# | like "#", but also find partial matches | 108 | | [ ] | gd | goto local declaration of identifier under the cursor | 109 | | [ ] | gD | goto global declaration of identifier under the cursor | 110 | 111 | ## Marks and motions 112 | 113 | | Status | Command | Description | 114 | | ------------------ | ----------------------------------------------------------- | ------------------------------------------------------ | 115 | | [x] | m{a-zA-Z} | mark current position with mark {a-zA-Z} | 116 | | [x] | `{a-z} | go to mark {a-z} within current file | 117 | | [x] | `{A-Z} | go to mark {A-Z} in any file | 118 | | [ ] | `{0-9} | go to the position where Vim was previously exited | 119 | | [ ] | `` | go to the position before the last jump | 120 | | [ ] | `" | go to the position when last editing this file | 121 | | [ ] | `[ | go to the start of the previously operated or put text | 122 | | [ ] | '[ | go to the start of the previously operated or put text | 123 | | [ ] | `] | go to the end of the previously operated or put text | 124 | | [ ] | '] | go to the end of the previously operated or put text | 125 | | [x] | `< | go to the start of the (previous) Visual area | 126 | | [x] | `> | go to the end of the (previous) Visual area | 127 | | [ ] | `. | go to the position of the last change in this file | 128 | | [ ] | '. | go to the position of the last change in this file | 129 | | [x] | '{a-zA-Z0-9[]'"<>.} | same as `, but on the first non-blank in the line | 130 | | [ ] | :marks | print the active marks | 131 | | [ ] | :1234: CTRL-O | go to Nth older position in jump list | 132 | | [ ] | :1234: CTRL-I | go to Nth newer position in jump list | 133 | | [ ] | :ju[mps] | print the jump list | 134 | 135 | ## Various motions 136 | 137 | | Status | Command | Description | 138 | | ------------------ | ------------------- | -------------------------------------------------------------------------------------------------- | 139 | | [x] | % | find the next brace, bracket and go to its match | 140 | | [ ] | :1234: H | go to the Nth line in the window, on the first non-blank | 141 | | [ ] | M | go to the middle line in the window, on the first non-blank | 142 | | [ ] | :1234: L | go to the Nth line from the bottom, on the first non-blank | 143 | | [ ] | :1234: go | go to Nth byte in the buffer | 144 | | [ ] | :[range]go[to][off] | go to [off] byte in the buffer | 145 | 146 | ## Scrolling 147 | 148 | | Status | Command | Description | 149 | | ------------------ | ------------- | ---------------------------------------------- | 150 | | [ ] | :1234: CTRL-E | window N lines downwards (default: 1) | 151 | | [ ] | :1234: CTRL-D | window N lines Downwards (default: 1/2 window) | 152 | | [ ] | :1234: CTRL-F | window N pages Forwards (downwards) | 153 | | [ ] | :1234: CTRL-Y | window N lines upwards (default: 1) | 154 | | [ ] | :1234: CTRL-U | window N lines Upwards (default: 1/2 window) | 155 | | [ ] | :1234: CTRL-B | window N pages Backwards (upwards) | 156 | | [ ] | z CR or zt | redraw, current line at top of window | 157 | | [ ] | z. or zz | redraw, current line at center of window | 158 | | [ ] | z- or zb | redraw, current line at bottom of window | 159 | 160 | ## Inserting text 161 | 162 | | Status | Command | Description | 163 | | ------------------ | --------- | ------------------------------------------------------------- | 164 | | [x] | :1234: a | append text after the cursor (N times) | 165 | | [x] | :1234: A | append text at the end of the line (N times) | 166 | | [x] | :1234: i | insert text before the cursor (N times) (also: Insert) | 167 | | [x] | :1234: I | insert text before the first non-blank in the line (N times) | 168 | | [ ] | :1234: gI | insert text in column 1 (N times) | 169 | | [ ] | gi | insert at the end of the last change | 170 | | [x] | :1234: o | open a new line below the current line, append text (N times) | 171 | | [x] | :1234: O | open a new line above the current line, append text (N times) | 172 | 173 | in Visual block mode: 174 | 175 | | Status | Command | Description | 176 | | ------------------ | ------- | ------------------------------------------------------- | 177 | | [x] | I | insert the same text in front of all the selected lines | 178 | | [x] | A | append the same text after all the selected lines | 179 | 180 | ## Insert mode keys 181 | 182 | leaving Insert mode: 183 | 184 | | Status | Command | Description | 185 | | ------------------ | ---------------- | ------------------------------------------- | 186 | | [x] | Esc | end Insert mode, back to Normal mode | 187 | | [ ] | CTRL-C | like Esc, but do not use an abbreviation | 188 | | [ ] | CTRL-O {command} | execute {command} and return to Insert mode | 189 | 190 | moving around: 191 | 192 | | Status | Command | Description | 193 | | ------------------ | ---------------- | --------------------------------------- | 194 | | [x] | cursor keys | move cursor left/right/up/down | 195 | | [ ] | shift-left/right | one word left/right | 196 | | [ ] | shift-up/down | one screenful backward/forward | 197 | | [ ] | End | cursor after last character in the line | 198 | | [ ] | Home | cursor to first character in the line | 199 | 200 | ## Special keys in Insert mode 201 | 202 | | Status | Command | Description | 203 | | ------------------------- | ---------------------------- | ------------------------------------------------------------------ | 204 | | [*] | NL or CR or CTRL-M or CTRL-J | begin new line | 205 | | [x] | BS or CTRL-H | delete the character before the cursor | 206 | | [ ] | CTRL-V {char}.. | insert character literally, or enter decimal byte value | 207 | | [ ] | CTRL-E | insert the character from below the cursor | 208 | | [ ] | CTRL-Y | insert the character from above the cursor | 209 | | [ ] | CTRL-A | insert previously inserted text | 210 | | [ ] | CTRL-@ | insert previously inserted text and stop Insert mode | 211 | | [ ] | CTRL-R {0-9a-z%#:.-="} | insert the contents of a register | 212 | | [ ] | CTRL-N | insert next match of identifier before the cursor | 213 | | [ ] | CTRL-P | insert previous match of identifier before the cursor | 214 | | [ ] | CTRL-X ... | complete the word before the cursor in various ways | 215 | | [ ] | Del | delete the character under the cursor | 216 | | [ ] | CTRL-W | delete word before the cursor | 217 | | [ ] | CTRL-U | delete all entered characters in the current line | 218 | | [ ] | CTRL-T | insert one shiftwidth of indent in front of the current line | 219 | | [ ] | CTRL-D | delete one shiftwidth of indent in front of the current line | 220 | | [ ] | 0 CTRL-D | delete all indent in the current line | 221 | | [ ] | ^ CTRL-D | delete all indent in the current line, restore indent in next line | 222 | 223 | ## Special inserts 224 | 225 | | Status | Command | Description | 226 | | --------- | ------------- | -------------------------------------------------------- | 227 | | [ ] | :r [file] | insert the contents of [file] below the cursor | 228 | | [ ] | :r! {command} | insert the standard output of {command} below the cursor | 229 | 230 | ## Deleting text 231 | 232 | | Status | Command | Description | 233 | | ------------------ | ---------------- | -------------------------------------------------- | 234 | | [x] | :1234: x | delete N characters under and after the cursor | 235 | | [x] | :1234: X | delete N characters before the cursor | 236 | | [x] | :1234: d{motion} | delete the text that is moved over with {motion} | 237 | | [x] | {visual}d | delete the highlighted text | 238 | | [x] | :1234: dd | delete N lines | 239 | | [ ] | :1234: D | delete to the end of the line (and N-1 more lines) | 240 | | [ ] | :1234: Del | delete N characters under and after the cursor | 241 | | [ ] | :1234: J | join N-1 lines (delete EOLs) | 242 | | [ ] | {visual}J | join the highlighted lines | 243 | | [ ] | :1234: gJ | like "J", but without inserting spaces | 244 | | [ ] | {visual}gJ | like "{visual}J", but without inserting spaces | 245 | | [ ] | :[range]d [x] | delete [range] lines [into register x] | 246 | 247 | ## Copying and moving text 248 | 249 | | Status | Command | Description | 250 | | ------------------ | ---------------- | ------------------------------------------------------ | 251 | | [ ] | "{char} | use register {char} for the next delete, yank, or put | 252 | | [ ] | "\* | use register `*` to access system clipboard | 253 | | [ ] | :reg | show the contents of all registers | 254 | | [ ] | :reg {arg} | show the contents of registers mentioned in {arg} | 255 | | [x] | :1234: y{motion} | yank the text moved over with {motion} into a register | 256 | | [x] | {visual}y | yank the highlighted text into a register | 257 | | [x] | :1234: yy | yank N lines into a register | 258 | | [ ] | :1234: Y | yank N lines into a register | 259 | | [x] | :1234: p | put a register after the cursor position (N times) | 260 | | [x] | :1234: P | put a register before the cursor position (N times) | 261 | | [ ] | :1234: ]p | like p, but adjust indent to current line | 262 | | [ ] | :1234: [p | like P, but adjust indent to current line | 263 | | [ ] | :1234: gp | like p, but leave cursor after the new text | 264 | | [ ] | :1234: gP | like P, but leave cursor after the new text | 265 | 266 | ## Changing text 267 | 268 | | Status | Command | Description | 269 | | ------------------------- | --------------- | ----------------------------------------------------------------------------| 270 | | [x] | :1234: r{char} | replace N characters with {char} | 271 | | [x] | {visual}r{char} | in Visual block, visual, or visual line modes: Replace each char of the selected text with {char} | 272 | | [x] | :1234: R | enter Replace mode (repeat the entered text N times) | 273 | | [ ] | :1234: gr{char} | replace N characters without affecting layout | 274 | | [ ] | :1234: gR | enter virtual Replace mode: Like Replace mode but without affecting layout | 275 | 276 | (change = delete text and enter Insert mode) 277 | 278 | | Status | Command | Description | 279 | | ------------------ | ----------------------- | ----------------------------------------------------------------------------------------------- | 280 | | [x] | :1234: c{motion} | change the text that is moved over with {motion} | 281 | | [x] | {visual}c | change the highlighted text | 282 | | [x] | :1234: cc | change N lines | 283 | | [x] | :1234: S | change N lines | 284 | | [x] | :1234: C | change to the end of the line (and N-1 more lines) | 285 | | [x] | :1234: s | change N characters | 286 | | [x] | {visual}c | in Visual block mode: Change each of the selected lines with the entered text | 287 | | [ ] | {visual}C | in Visual block mode: Change each of the selected lines until end-of-line with the entered text | 288 | | [x] | {visual}~ | switch case for highlighted text | 289 | | [x] | {visual}u | make highlighted text lowercase | 290 | | [x] | {visual}U | make highlighted text uppercase | 291 | | [x] | g~{motion} | switch case for the text that is moved over with {motion} | 292 | | [x] | gu{motion} | make the text that is moved over with {motion} lowercase | 293 | | [x] | gU{motion} | make the text that is moved over with {motion} uppercase | 294 | | [ ] | {visual}g? | perform rot13 encoding on highlighted text | 295 | | [ ] | g?{motion} | perform rot13 encoding on the text that is moved over with {motion} | 296 | | [x] | :1234: <{motion} | move the lines that are moved over with {motion} one shiftwidth left | 297 | | [x] | :1234: << | move N lines one shiftwidth left | 298 | | [x] | :1234: >{motion} | move the lines that are moved over with {motion} one shiftwidth right | 299 | | [x] | :1234: >> | move N lines one shiftwidth right | 300 | | [ ] | :1234: CTRL-A | add N to the number at or after the cursor | 301 | | [ ] | :1234: CTRL-X | subtract N from the number at or after the cursor | 302 | | [ ] | :1234: gq{motion} | format the lines that are moved over with {motion} to 'textwidth' length | 303 | | [ ] | :[range]ce[nter][width] | center the lines in [range] | 304 | | [ ] | :[range]le[ft][indent] | left-align the lines in [range] (with [indent]) | 305 | | [ ] | :[ranee]ri[ght][width] | right-align the lines in [range] | 306 | 307 | ## Complex changes 308 | 309 | | Status | Command | Description | 310 | | -------------------------------------- | ---------------------------------------------- | ----------- | 311 | | [x] | :[range]s[ubstitute]/{pattern}/{string}/[g][c] | substitute {pattern} by {string} in [range] lines; with [g], replace all occurrences of {pattern}; with [c], confirm each replacement | 312 | | [ ] | :[range]s[ubstitute][g][c] | repeat previous ":s" with new range and options | 313 | | [ ] | & | Repeat previous ":s" on current line without options | 314 | | [ ] | :1234: `!{motion}{command}` | filter the lines that are moved over through {command} | 315 | | [ ] | :1234: `!!{command}` | filter N lines through {command} | 316 | | [ ] | `{visual}!{command}` | filter the highlighted lines through {command} | 317 | | [ ] | `:[range]! {command}` | filter [range] lines through {command} | 318 | | [ ] | :1234: ={motion} | filter the lines that are moved over through 'equalprg' | 319 | | [ ] | :1234: == | filter N lines through 'equalprg' | 320 | | [ ] | {visual}= | filter the highlighted lines through 'equalprg' | 321 | | [ ] | :[range]ret[ab][!] [tabstop] | set 'tabstop' to new value and adjust white space accordingly | 322 | 323 | ## Visual mode 324 | 325 | | Status | Command | Description | 326 | | ------------------ | ------- | --------------------------------------------------- | 327 | | [x] | v | start highlighting characters or stop highlighting | 328 | | [x] | V | start highlighting linewise or stop highlighting | 329 | | [x] | CTRL-V | start highlighting blockwise or stop highlighting | 330 | | [x] | o | exchange cursor position with start of highlighting | 331 | | [ ] | gv | start highlighting on previous visual area | 332 | 333 | ## Text objects (only in Visual mode or after an operator) 334 | 335 | | Status | Command | Description | 336 | | ------------------ | ------------------------------------------------- | ----------------------------------------------------------- | 337 | | [x] | :1234: aw | Select "a word" | 338 | | [x] | :1234: iw | Select "inner word" | 339 | | [x] | :1234: aW | Select "a WORD" | 340 | | [x] | :1234: iW | Select "inner WORD" | 341 | | [ ] | :1234: as | Select "a sentence" | 342 | | [ ] | :1234: is | Select "inner sentence" | 343 | | [ ] | :1234: ap | Select "a paragraph" | 344 | | [ ] | :1234: ip | Select "inner paragraph" | 345 | | [x] | :1234: a], a[ | select '[' ']' blocks | 346 | | [x] | :1234: i], i[ | select inner '[' ']' blocks | 347 | | [x] | :1234: ab, a(, a) | Select "a block" (from "[(" to "])") | 348 | | [x] | :1234: ib, i), i( | Select "inner block" (from "[(" to "])") | 349 | | [x] | :1234: a>, a< | Select "a <> block" | 350 | | [x] | :1234: i>, i< | Select "inner <> block" | 351 | | [x] | :1234: aB, a{, a} | Select "a Block" (from "[{" to "]}") | 352 | | [x] | :1234: iB, i{, i} | Select "inner Block" (from "[{" to "]}") | 353 | | [ ] | :1234: at | Select "a tag block" (from <aaa> to </aaa>) | 354 | | [ ] | :1234: it | Select "inner tag block" (from <aaa> to </aaa>) | 355 | | [ ] | :1234: a' | Select "a single quoted string" | 356 | | [ ] | :1234: i' | Select "inner single quoted string" | 357 | | [ ] | :1234: a" | Select "a double quoted string" | 358 | | [ ] | :1234: i" | Select "inner double quoted string" | 359 | | [ ] | :1234: a` | Select "a backward quoted string" | 360 | | [ ] | :1234: i` | Select "inner backward quoted string" | 361 | 362 | ## Repeating commands 363 | 364 | | Status | Command | Description | 365 | | ------------------------- | --------------------------------- | -------------- | 366 | | [x] | :1234: . | repeat last change (with count replaced with N) | Content changes that don't happen under cursor can not be repeated. | 367 | | [x] | q{a-z} | record typed characters into register {a-z} | 368 | | [ ] | q{A-Z} | record typed characters, appended to register {a-z} | 369 | | [x] | q | stop recording | 370 | | [x] | :1234: @{a-z} | execute the contents of register {a-z} (N times) | 371 | | [x] | :1234: @@ | repeat previous @{a-z} (N times) | 372 | | [ ] | :@{a-z} | execute the contents of register {a-z} as an Ex command | 373 | | [ ] | :@@ | repeat previous :@{a-z} | 374 | | [ ] | :[range]g[lobal]/{pattern}/[cmd] | execute Ex command [cmd](default: ':p') on the lines within [range] where {pattern} matches | 375 | | [ ] | :[range]g[lobal]!/{pattern}/[cmd] | execute Ex command [cmd](default: ':p') on the lines within [range] where {pattern} does NOT match | 376 | | [ ] | :so[urce] {file} | read Ex commands from {file} | 377 | | [ ] | :so[urce]! {file} | read Vim commands from {file} | 378 | | [ ] | :sl[eep][sec] | don't do anything for [sec] seconds | 379 | | [ ] | :1234: gs | goto Sleep for N seconds | 380 | 381 | ## Undo/Redo commands 382 | 383 | | Status | Command | Description | Note | 384 | | ------------------ | ------------- | -------------------------- | ---------------------------------------------------------- | 385 | | [x] | :1234: u | undo last N changes | Current implementation may not cover every case perfectly. | 386 | | [x] | :1234: CTRL-R | redo last N undone changes | As above. | 387 | | [ ] | U | restore last changed line | 388 | 389 | ## Ex ranges 390 | 391 | | Status | Command | Description | 392 | | ------------------------- | ------------- | ---------------------------------------------------------------------------- | 393 | | [x] | , | separates two line numbers | 394 | | [ ] | ; | idem, set cursor to the first line number before interpreting the second one | 395 | | [x] | {number} | an absolute line number | 396 | | [x] | . | the current line | 397 | | [x] | \$ | the last line in the file | 398 | | [x] | % | equal to 1,\$ (the entire file) | 399 | | [ ] | \* | equal to '<,'> (visual area) | 400 | | [*] | 't | position of mark t | 401 | | [*] | /{pattern}[/] | the next line where {pattern} matches | 402 | | [*] | ?{pattern}[?] | the previous line where {pattern} matches | 403 | | [ ] | +[num] | add [num] to the preceding line number (default: 1) | 404 | | [ ] | -[num] | subtract [num] from the preceding line number (default: 1) | 405 | 406 | ## Editing a file 407 | 408 | | Status | Command | Description | 409 | | ------------------------- | -------------- | ------------ | 410 | | [ ] | :e[dit] {file} | Edit {file}. | 411 | 412 | ## Multi-window commands 413 | 414 | | Status | Command | Description | 415 | | ------------------------- | ----------------- | ----------------------------------------------------------------------- | 416 | | [ ] | :e[dit] {file} | Edit {file}. | 417 | | [ ] | <ctrl-w> hl | Switching between windows. | 418 | | [ ] | :sp {file} | Split current window in two. | 419 | | [ ] | :vsp {file} | Split vertically current window in two. | 420 | | [ ] | <ctrl-w> s | Split current window in two. | 421 | | [ ] | <ctrl-w> v | Split vertically current window in two. | 422 | | [ ] | <ctrl-w> o | Close other editor groups. | 423 | | [ ] | :new | Create a new window horizontally and start editing an empty file in it. | 424 | | [ ] | :vne[w] | Create a new window vertically and start editing an empty file in it. | 425 | -------------------------------------------------------------------------------- /change.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | (require "core.rkt" "move.rkt" "wrapped-move-scope.rkt" "common-utils.rkt") 3 | 4 | (provide (all-defined-out)) 5 | 6 | (module+ test (require typed/rackunit)) 7 | 8 | ; line-insert-char! : line char index -> void 9 | ; insert char c in the line l at index i 10 | (: line-insert-char (-> String Char Natural String)) 11 | (define (line-insert-char s c i) 12 | (define n (string-length s)) 13 | (unless (<= i n) (error 'line-insert-char "index i greater than line length, i=~a, l=~a" i s)) 14 | (cond [(= i n) (string-append s (string c))] 15 | [(= i 0) (string-append (string c) s)] 16 | [else (string-append (substring s 0 i) (string c) (substring s i))])) 17 | 18 | (module+ test 19 | (check-equal? (line-insert-char "abc" #\d 0) "dabc") 20 | (check-equal? (line-insert-char "abc" #\d 1) "adbc") 21 | (check-equal? (line-insert-char "abc" #\d 2) "abdc") 22 | (check-equal? (line-insert-char "abc" #\d 3) "abcd") 23 | (check-exn exn:fail? (lambda () (line-insert-char "abc" #\d 4)))) 24 | 25 | ; line-replace-char : string char index -> string 26 | ; replace in the line l at index i 27 | (: line-replace-after-char (-> String Char Natural String)) 28 | (define (line-replace-after-char s c i) 29 | (define n (string-length s)) 30 | (unless (<= i n) (error 'line-replace-char "index i greater than line length, i=~a, l=~a" i s)) 31 | (string-append (substring s 0 i) (string c) (substring s (min (+ 1 i) n)))) 32 | 33 | (module+ test 34 | (check-equal? (line-replace-after-char "abc" #\d 0) "dbc") 35 | (check-equal? (line-replace-after-char "abc" #\d 1) "adc") 36 | (check-equal? (line-replace-after-char "abc" #\d 2) "abd") 37 | (check-equal? (line-replace-after-char "abc" #\d 3) "abcd") 38 | (check-exn exn:fail? (lambda () (line-replace-after-char "abc" #\d 4)))) 39 | 40 | ; line-delete-after-char : string index -> string 41 | ; delete in the line l at index i 42 | (: line-delete-after-char (-> String Natural (Option String))) 43 | (define (line-delete-after-char s i) 44 | (define n (string-length s)) 45 | (unless (<= i n) (error 'line-delete-after-char "index i greater than line length, i=~a, l=~a" i s)) 46 | (cond [(= i 0) #f] ; or error 47 | [else (string-append (substring s 0 (- i 1)) (substring s i))])) 48 | 49 | (module+ test 50 | (check-equal? (line-delete-after-char "abc" 0) #f) 51 | (check-equal? (line-delete-after-char "abc" 1) "bc") 52 | (check-equal? (line-delete-after-char "abc" 2) "ac") 53 | (check-equal? (line-delete-after-char "abc" 3) "ab")) 54 | 55 | (: split-line-at (-> Point (Listof String) (Listof String))) 56 | (define (split-line-at p lines) 57 | (define-values (row col) (Point-row-col p)) 58 | (define-values (l0 l123) (split-at lines row)) 59 | (define-values (l12* l3) (split-at l123 1)) 60 | (define l12 (first l12*)) 61 | (define l1 (substring l12 0 col)) 62 | (define l2 (substring l12 col)) 63 | (append l0 (list l1 l2) l3)) 64 | 65 | (module+ test 66 | (check-equal? (split-line-at (Point 0 0 0) (list "abc")) '("" "abc")) 67 | (check-equal? (split-line-at (Point 0 1 1) (list "abc")) '("a" "bc")) 68 | (check-equal? (split-line-at (Point 0 2 2) (list "abc")) '("ab" "c")) 69 | (check-equal? (split-line-at (Point 0 3 3) (list "abc")) '("abc" ""))) 70 | 71 | (: split-line-point-lines (-> Point (Listof String) (values Point (Listof String)))) 72 | (define (split-line-point-lines p lines) 73 | (define updated-lines (split-line-at p lines)) 74 | (define-values (row col) (Point-row-col p)) 75 | (values (down-point (line-start-point row) updated-lines) updated-lines)) 76 | 77 | (module+ test 78 | (let-values ([(p lines) (split-line-point-lines (Point 0 0 0) (list "abc"))]) 79 | (check-equal? p (Point 1 0 0)) 80 | (check-equal? lines '("" "abc"))) 81 | (let-values ([(p lines) (split-line-point-lines (Point 0 1 1) (list "abc"))]) 82 | (check-equal? p (Point 1 0 0)) 83 | (check-equal? lines '("a" "bc"))) 84 | (let-values ([(p lines) (split-line-point-lines (Point 0 2 2) (list "abc"))]) 85 | (check-equal? p (Point 1 0 0)) 86 | (check-equal? lines '("ab" "c"))) 87 | (let-values ([(p lines) (split-line-point-lines (Point 0 3 3) (list "abc"))]) 88 | (check-equal? p (Point 1 0 0)) 89 | (check-equal? lines '("abc" "")))) 90 | 91 | (: lines-insert-char-at-point (-> Char Point (Listof String) (Listof String))) 92 | (define (lines-insert-char-at-point c p lines) 93 | (define-values (row col) (Point-row-col p)) 94 | (define l (list-ref lines row)) 95 | (list-set lines row (line-insert-char l c col))) 96 | 97 | (module+ test 98 | (check-equal? (lines-insert-char-at-point #\d (Point 0 0 0) (list "abc")) '("dabc")) 99 | (check-equal? (lines-insert-char-at-point #\d (Point 0 1 1) (list "abc")) '("adbc")) 100 | (check-equal? (lines-insert-char-at-point #\d (Point 0 2 2) (list "abc")) '("abdc")) 101 | (check-equal? (lines-insert-char-at-point #\d (Point 0 3 3) (list "abc")) '("abcd"))) 102 | 103 | (: lines-replace-char-after-point (-> Char Point (Listof String) (Listof String))) 104 | (define (lines-replace-char-after-point c p lines) 105 | (define-values (row col) (Point-row-col p)) 106 | (define l (list-ref lines row)) 107 | (list-set lines row (line-replace-after-char l c col))) 108 | 109 | (module+ test 110 | (check-equal? (lines-replace-char-after-point #\d (Point 0 0 0) (list "abc")) '("dbc")) 111 | (check-equal? (lines-replace-char-after-point #\d (Point 0 1 1) (list "abc")) '("adc")) 112 | (check-equal? (lines-replace-char-after-point #\d (Point 0 2 2) (list "abc")) '("abd")) 113 | (check-equal? (lines-replace-char-after-point #\d (Point 0 3 3) (list "abc")) '("abcd"))) 114 | 115 | (: lines-delete-char-after-point (-> Point (Listof String) Boolean (values Point (Listof String)))) 116 | (define (lines-delete-char-after-point p lines *-mode?) 117 | (define-values (row col) (Point-row-col p)) 118 | (define l (list-ref lines row)) 119 | (with-handlers ([exn:fail? 120 | (λ (e) (values ((if *-mode? after-line-end-point line-end-point) row l) lines))]) 121 | (define new-point (if (= col ((if *-mode? after-line-end-col line-end-col) l)) 122 | (left-point p) 123 | p)) 124 | (define new-line 125 | (cast 126 | (line-delete-after-char l (+ col 1)) 127 | String)) 128 | (define new-lines (list-set lines row new-line)) 129 | (values new-point new-lines))) 130 | 131 | (module+ test 132 | (let-values ([(p lines) (lines-delete-char-after-point (Point 0 0 0) (list "abc") #f)]) 133 | (check-equal? p (Point 0 0 0)) 134 | (check-equal? lines '("bc"))) 135 | (let-values ([(p lines) (lines-delete-char-after-point (Point 0 1 1) (list "abc") #f)]) 136 | (check-equal? p (Point 0 1 1)) 137 | (check-equal? lines '("ac"))) 138 | (let-values ([(p lines) (lines-delete-char-after-point (Point 0 2 2) (list "abc") #f)]) 139 | (check-equal? p (Point 0 1 1)) 140 | (check-equal? lines '("ab"))) 141 | (let-values ([(p lines) (lines-delete-char-after-point (Point 0 3 3) (list "abc") #f)]) 142 | (check-equal? p (Point 0 2 +inf.0)) 143 | (check-equal? lines '("abc")))) 144 | 145 | (: delete-scope (-> Scope (Listof String) (values Point (Listof String)))) 146 | (define (delete-scope scope lines) 147 | (replace-scope scope lines '())) 148 | 149 | (module+ test 150 | (let-values ([(p lines) (delete-scope (Scope (Point 0 0 0) (Point 0 1 1) #f #f 'char) (list "abc"))]) 151 | (check-equal? p (Point 0 0 0)) 152 | (check-equal? lines '("bc"))) 153 | (let-values ([(p lines) (delete-scope (Scope (Point 0 0 0) (Point 0 1 1) #f #t 'char) (list "abc"))]) 154 | (check-equal? p (Point 0 0 0)) 155 | (check-equal? lines '("bc"))) 156 | (let-values ([(p lines) (delete-scope (Scope (Point 0 0 0) (Point 1 1 1) #f #t 'char) (list "abc" "def"))]) 157 | (check-equal? p (Point 0 0 0)) 158 | (check-equal? lines '("ef"))) 159 | (let-values ([(p lines) (delete-scope (Scope (Point 0 1 1) (Point 1 1 1) #f #t 'char) (list "abc" "def"))]) 160 | (check-equal? p (Point 0 1 1)) 161 | (check-equal? lines '("aef"))) 162 | (let-values ([(p lines) (delete-scope (Scope (Point 0 0 0) (Point 0 1 1) #f #f 'line) (list "abc"))]) 163 | (check-equal? p (Point 0 0 0)) 164 | (check-equal? lines '("abc"))) 165 | (let-values ([(p lines) (delete-scope (Scope (Point 0 0 0) (Point 0 1 1) #f #t 'line) (list "abc"))]) 166 | (check-equal? p (Point 0 0 0)) 167 | (check-equal? lines '(""))) 168 | (let-values ([(p lines) (delete-scope (Scope (Point 0 0 0) (Point 1 1 1) #f #t 'line) (list "abc"))]) 169 | (check-equal? p (Point 0 0 0)) 170 | (check-equal? lines '(""))) 171 | (let-values ([(p lines) (delete-scope (Scope (Point 1 1 1) (Point 1 1 1) #f #t 'line) (list "abc" "def"))]) 172 | (check-equal? p (Point 0 0 0)) 173 | (check-equal? lines '("abc")))) 174 | 175 | (: insert-lines-at (->* (Point (Listof String) (Listof String)) (Symbol) (values Point (Listof String)))) 176 | (define (insert-lines-at start lines inserted-lines [mode 'char]) 177 | (define scope (Scope start start #f #f mode)) 178 | (replace-scope scope lines inserted-lines)) 179 | 180 | (module+ test 181 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) '() '())]) 182 | (check-equal? lines (Point 0 0 0)) 183 | (check-equal? p '(""))) 184 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) '() '(""))]) 185 | (check-equal? lines (Point 0 0 0)) 186 | (check-equal? p '(""))) 187 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) '() '("abc"))]) 188 | (check-equal? lines (Point 0 3 3)) 189 | (check-equal? p '("abc"))) 190 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) (list "") '())]) 191 | (check-equal? lines (Point 0 0 0)) 192 | (check-equal? p '(""))) 193 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) (list "") (list ""))]) 194 | (check-equal? lines (Point 0 0 0)) 195 | (check-equal? p '(""))) 196 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) (list "") (list "def"))]) 197 | (check-equal? lines (Point 0 3 3)) 198 | (check-equal? p '("def"))) 199 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) (list " ") (list "def"))]) 200 | (check-equal? lines (Point 0 3 3)) 201 | (check-equal? p '("def "))) 202 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) (list "abc") (list "def"))]) 203 | (check-equal? lines (Point 0 3 3)) 204 | (check-equal? p '("defabc"))) 205 | (let-values ([(lines p) (insert-lines-at (Point 0 1 1) (list "abc") (list "def"))]) 206 | (check-equal? lines (Point 0 4 4)) 207 | (check-equal? p '("adefbc"))) 208 | (let-values ([(lines p) (insert-lines-at (Point 0 2 2) (list "abc" "123") (list "def"))]) 209 | (check-equal? lines (Point 0 5 5)) 210 | (check-equal? p '("abdefc" "123"))) 211 | (let-values ([(lines p) (insert-lines-at (Point 0 3 3) (list "abc" "123") (list "def"))]) 212 | (check-equal? lines (Point 0 6 6)) 213 | (check-equal? p '("abcdef" "123"))) 214 | (let-values ([(lines p) (insert-lines-at (Point 1 2 2) (list "abc" "123") (list "def"))]) 215 | (check-equal? lines (Point 1 5 5)) 216 | (check-equal? p '("abc" "12def3"))) 217 | (let-values ([(lines p) (insert-lines-at (Point 1 0 0) (list "abc" "123") (list "") 'line)]) 218 | (check-equal? lines (Point 1 0 0)) 219 | (check-equal? p '("abc" "" "123"))) 220 | (let-values ([(lines p) (insert-lines-at (Point 0 0 0) (list "abc" "123") (list "def") 'line)]) 221 | (check-equal? lines (Point 0 0 0)) 222 | (check-equal? p '("def" "abc" "123"))) 223 | (let-values ([(lines p) (insert-lines-at (Point 1 1 1) (list "abc" "123") (list "def") 'line)]) 224 | (check-equal? lines (Point 1 0 0)) 225 | (check-equal? p '("abc" "def" "123"))) 226 | (let-values ([(lines p) (insert-lines-at (Point 2 2 2) (list "abc" "123") (list "def") 'line)]) 227 | (check-equal? lines (Point 2 0 0)) 228 | (check-equal? p '("abc" "123" "def")))) 229 | 230 | (: replace-line-scope (-> Scope (Listof String) (Listof String) (values Point (Listof String)))) 231 | (define (replace-line-scope scope lines inserted-lines) 232 | (match-define (Scope start end dir include-real-end? mode) scope) 233 | ; for non-line-mode, we include right end only with both dir and include-real-end? true. 234 | (define include-right-end? (and dir include-real-end?)) 235 | (define l0 (take lines (Point-row start))) 236 | (define real-end-row (+ (Point-row end) (if include-real-end? 1 0))) 237 | (define l3 (if (>= (length lines) real-end-row) (drop lines real-end-row) '())) 238 | (define new-lines (append l0 inserted-lines l3)) 239 | (define real-lines (if (empty? new-lines) (list "") new-lines)) 240 | (define new-row 241 | (cast 242 | (min (sub1 (length real-lines)) (+ (Point-row start) (max 1 (length inserted-lines)) -1)) 243 | Natural)) 244 | (define new-point 245 | (line-start-point new-row)) 246 | (values new-point real-lines)) 247 | 248 | (: replace-scope (-> Scope (Listof String) (Listof String) (values Point (Listof String)))) 249 | (define (replace-scope scope lines inserted-lines) 250 | (define mode (Scope-mode scope)) 251 | (cond 252 | [(equal? mode 'line) 253 | (replace-line-scope scope lines inserted-lines)] 254 | [(equal? mode 'char) 255 | (replace-char-scope scope lines inserted-lines)] 256 | [(equal? mode 'block) 257 | (replace-block-scope scope lines inserted-lines)] 258 | [else (error 'missing-case-of-scope-mode)])) 259 | 260 | (: replace-char-scope (-> Scope (Listof String) (Listof String) (values Point (Listof String)))) 261 | (define (replace-char-scope scope lines inserted-lines) 262 | (match-define (Scope start end dir include-real-end? mode) scope) 263 | ; for non-line-mode, we include right end only with both dir and include-real-end? true. 264 | (define include-right-end? (and dir include-real-end?)) 265 | (define-values (l0 l1 _ l3 l4) (split-five-at lines (Point-row start) (Point-row end))) 266 | (define new-lines 267 | (cond 268 | [(>= (length inserted-lines) 2) 269 | (define-values (r1 r2 r3) (first-middle-last inserted-lines)) 270 | (define m1 (line-merge (first-or-empty-string l1) 271 | (Point-col start) 272 | r1 273 | 0)) 274 | (define end-col (+ (Point-col end) (if include-right-end? 1 0))) 275 | (define m3 (line-merge r3 276 | (string-length r3) 277 | (first-or-empty-string l3) 278 | end-col)) 279 | (append l0 (list m1) r2 (list m3) l4)] 280 | [else 281 | (define l123-b (first-or-empty-string inserted-lines)) 282 | (define m1 (line-merge (first-or-empty-string l1) 283 | (Point-col start) 284 | l123-b 285 | 0)) 286 | (define end-col (+ (Point-col end) (if include-right-end? 1 0))) 287 | (define m (line-merge m1 288 | (string-length m1) 289 | (first-or-empty-string l3) 290 | end-col)) 291 | (append l0 (list m) l4)]) 292 | ) 293 | (define real-lines (if (empty? new-lines) (list "") new-lines)) 294 | (define new-row 295 | (cast 296 | (min (sub1 (length real-lines)) (+ (Point-row start) (max 1 (length inserted-lines)) -1)) 297 | Natural)) 298 | (define new-point 299 | (after-lines-point start inserted-lines)) 300 | (values new-point real-lines)) 301 | 302 | (: replace-block-scope (-> Scope (Listof String) (Listof String) (values Point (Listof String)))) 303 | (define (replace-block-scope scope lines inserted-lines) 304 | ;(displayln (~e 'replace-block-scope scope lines inserted-lines)) 305 | (match-define (Scope start end dir include-real-end? mode) scope) 306 | (define row-diff (- (Point-row end) (Point-row start))) 307 | (define row-len (if (empty-scope? scope) (length inserted-lines) (add1 row-diff))) 308 | ;(displayln (~e 'start start 'end end 'row-len row-len 'inserted-lines inserted-lines)) 309 | (unless (or (empty? inserted-lines) (= (length inserted-lines) row-len)) 310 | (error (~e "incorrect-params" row-len inserted-lines))) 311 | ; for non-line-mode, we include right end only with both dir and include-real-end? true. 312 | (define include-right-end? (and dir include-real-end?)) 313 | (define end-row+1 (cast (+ (Point-row start) row-len) Natural)) 314 | (define-values (before middle after) (before-middle-after lines (Point-row start) end-row+1)) 315 | (define col0 (Point-col start)) 316 | (define col1 (Point-col end)) 317 | (define col-min (min col0 col1)) 318 | (define col-max (max col0 col1)) 319 | (define real-col-end (if include-right-end? (add1 col-max) col-max)) 320 | (define real-inserted-lines (if (empty? inserted-lines) (make-list row-len "") inserted-lines)) 321 | (define new-middle 322 | (for/list : (Listof String) 323 | ([l middle] 324 | [ins real-inserted-lines]) 325 | (string-append 326 | (substring-in-range l 0 col-min) 327 | ins 328 | (substring-in-range l real-col-end)))) 329 | ;(displayln (~e 'middle middle 'inserted 'inserted-lines 'new-middle new-middle)) 330 | (define new-lines (append before new-middle after)) 331 | (define real-lines (if (empty? new-lines) (list "") new-lines)) 332 | (values start real-lines)) 333 | 334 | (module+ test 335 | (let-values ([(p lines) (replace-block-scope (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'block) '("two" "another.") '("123" "456"))]) 336 | (check-equal? p (Point 0 1 1)) 337 | (check-equal? lines '("t123wo" "a456nother.")))) 338 | 339 | (module+ test 340 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 0 0 0) #f #f 'char) (list "abc") '("1"))]) 341 | (check-equal? p (Point 0 1 1)) 342 | (check-equal? lines '("1abc"))) 343 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 0 0 0) #f #f 'char) (list "abc") '("1" "2"))]) 344 | (check-equal? p (Point 1 1 1)) 345 | (check-equal? lines '("1" "2abc"))) 346 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 0 0 0) #f #f 'char) (list "abc") '("1" "2" "3"))]) 347 | (check-equal? p (Point 2 1 1)) 348 | (check-equal? lines '("1" "2" "3abc"))) 349 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 0 0 0) #f #t 'char) (list "abc") '("1" "2" "3"))]) 350 | (check-equal? p (Point 2 1 1)) 351 | (check-equal? lines '("1" "2" "3abc"))) 352 | (let-values ([(p lines) (replace-scope (Scope (Point 0 1 1) (Point 0 1 1) #f #f 'char) (list "abc") '("1" "2" "3"))]) 353 | (check-equal? p (Point 2 1 1)) 354 | (check-equal? lines '("a1" "2" "3bc"))) 355 | (let-values ([(p lines) (replace-scope (Scope (Point 0 1 1) (Point 0 1 1) #f #t 'char) (list "abc") '("1" "2" "3"))]) 356 | (check-equal? p (Point 2 1 1)) 357 | (check-equal? lines '("a1" "2" "3bc"))) 358 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 0 1 1) #f #f 'char) (list "abc") '("1" "2" "3"))]) 359 | (check-equal? p (Point 2 1 1)) 360 | (check-equal? lines '("1" "2" "3bc"))) 361 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 0 1 1) #f #t 'char) (list "abc") '("1" "2" "3"))]) 362 | (check-equal? p (Point 2 1 1)) 363 | (check-equal? lines '("1" "2" "3bc"))) 364 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 0 1 1) #f #t 'line) (list "abc") '("1" "2" "3"))]) 365 | (check-equal? p (Point 2 0 0)) 366 | (check-equal? lines '("1" "2" "3"))) 367 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 1 1 1) #f #t 'char) (list "abc" "def") '("1" "2" "3"))]) 368 | (check-equal? p (Point 2 1 1)) 369 | (check-equal? lines '("1" "2" "3ef"))) 370 | (let-values ([(p lines) (replace-scope (Scope (Point 0 1 1) (Point 1 1 1) #f #t 'char) (list "abc" "def") '("1" "2" "3"))]) 371 | (check-equal? p (Point 2 1 1)) 372 | (check-equal? lines '("a1" "2" "3ef"))) 373 | (let-values ([(p lines) (replace-scope (Scope (Point 0 0 0) (Point 1 1 1) #f #t 'line) (list "abc" "def") '("1" "2" "3"))]) 374 | (check-equal? p (Point 2 0 0)) 375 | (check-equal? lines '("1" "2" "3"))) 376 | (let-values ([(p lines) (replace-scope (Scope (Point 0 1 1) (Point 1 1 1) #f #t 'line) (list "abc" "def") '("1" "2" "3"))]) 377 | (check-equal? p (Point 2 0 0)) 378 | (check-equal? lines '("1" "2" "3")))) 379 | 380 | (define shift-width 4) 381 | 382 | (: make-indention (-> String)) 383 | (define (make-indention) 384 | (make-string shift-width #\space)) 385 | 386 | (: right-shift-line (-> String String)) 387 | (define (right-shift-line l) 388 | (string-append (make-indention) l)) 389 | 390 | (module+ test 391 | (check-equal? (right-shift-line "abc") " abc")) 392 | 393 | (: left-shift-line-drop-length (-> String Natural)) 394 | (define (left-shift-line-drop-length l) 395 | (define ^-p (^-point 0 l)) 396 | (min shift-width (Point-col ^-p))) 397 | 398 | (: left-shift-line (-> String String)) 399 | (define (left-shift-line l) 400 | (define drop-length (left-shift-line-drop-length l)) 401 | (substring l drop-length)) 402 | 403 | (module+ test 404 | (check-equal? (left-shift-line "abc") "abc") 405 | (check-equal? (left-shift-line " abc") " abc")) 406 | 407 | (: shift-scope (-> Scope (Listof String) (-> String String) (Values Point (Listof String)))) 408 | (define (shift-scope s lines shift-line-func) 409 | (match-define (Scope (Point row1 _ _) (Point row2 _ _) _ _ _) s) 410 | (cond 411 | [(empty? lines) (error 'empty-lines-for-right-shift)] 412 | [else 413 | (define-values (before-middle after) (split-at lines (add1 row2))) 414 | (define-values (before middle) (split-at before-middle row1)) 415 | (define new-middle 416 | (for/list : (Listof String) 417 | ([l : String middle]) 418 | (shift-line-func l))) 419 | (define new-lines (append before new-middle after)) 420 | (define new-point (^-point row1 (list-ref new-lines row1))) 421 | (values new-point new-lines)])) 422 | 423 | (: right-shift-scope (-> Scope (Listof String) (Values Point (Listof String)))) 424 | (define (right-shift-scope s lines) 425 | (shift-scope s lines right-shift-line)) 426 | 427 | (: left-shift-scope (-> Scope (Listof String) (Values Point (Listof String)))) 428 | (define (left-shift-scope s lines) 429 | (shift-scope s lines left-shift-line)) 430 | 431 | (module+ test 432 | (let-values ([(p lines) (right-shift-scope (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'char) '("abc"))]) 433 | (check-equal? p (Point 0 4 4)) 434 | (check-equal? lines '(" abc"))) 435 | (let-values ([(p lines) (right-shift-scope (Scope (Point 0 0 0) (Point 0 1 1) #t #t 'char) '("abc"))]) 436 | (check-equal? p (Point 0 4 4)) 437 | (check-equal? lines '(" abc"))) 438 | (let-values ([(p lines) (right-shift-scope (Scope (Point 0 1 1) (Point 1 0 0) #t #t 'char) '("abc" "def"))]) 439 | (check-equal? p (Point 0 4 4)) 440 | (check-equal? lines '(" abc" " def"))) 441 | (let-values ([(p lines) (right-shift-scope (Scope (Point 1 1 1) (Point 2 0 0) #t #t 'char) '("abc" "def" "ghi"))]) 442 | (check-equal? p (Point 1 4 4)) 443 | (check-equal? lines '("abc" " def" " ghi"))) 444 | (let-values ([(p lines) (left-shift-scope (Scope (Point 1 1 1) (Point 2 0 0) #t #t 'char) '(" abc" " def" " ghi"))]) 445 | (check-equal? p (Point 1 0 0)) 446 | (check-equal? lines '(" abc" "def" " ghi"))) 447 | ) -------------------------------------------------------------------------------- /common-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (module+ test (require typed/rackunit)) 6 | 7 | (: line-merge (-> String Natural String Natural String)) 8 | (define (line-merge l1 end-col l2 start-col) 9 | ;(displayln (~e line-merge l1 end-col l2 start-col)) 10 | (define str1 l1) 11 | (define str2 l2) 12 | (string-append (substring str1 0 end-col) 13 | (if (< start-col (string-length l2)) 14 | (substring str2 start-col) 15 | ""))) 16 | 17 | ;;; l1 over l2 18 | (: split-three-at : (All (T) (Listof T) Natural -> (Values (Listof T) (Listof T) (Listof T)))) 19 | (define (split-three-at lst pos) 20 | (when (> pos (length lst)) (error 'split-three-at-out-of-bound (~a "index" pos " > length" (length lst)))) 21 | (define-values (l0 l12) (split-at lst pos)) 22 | (define-values (l1 l2) (if (empty? l12) (values '() '()) (split-at l12 1))) 23 | (values l0 l1 l2)) 24 | 25 | (module+ test 26 | (let-values ([(l0 l1 l2) (split-three-at (list "abc") 0)]) 27 | (check-equal? l0 '()) 28 | (check-equal? l1 '("abc")) 29 | (check-equal? l2 '())) 30 | (let-values ([(l0 l1 l2) (split-three-at (list "abc") 1)]) 31 | (check-equal? l0 '("abc")) 32 | (check-equal? l1 '()) 33 | (check-equal? l2 '())) 34 | ;(check-exn exn:fail? (lambda () (split-three-at (list "abc") 2))) 35 | (let-values ([(l0 l1 l2) (split-three-at (list "abc") 0)]) 36 | (check-equal? l0 '()) 37 | (check-equal? l1 '("abc")) 38 | (check-equal? l2 '())) 39 | (let-values ([(l0 l1 l2) (split-three-at (list "abc" "") 1)]) 40 | (check-equal? l0 '("abc")) 41 | (check-equal? l1 '("")) 42 | (check-equal? l2 '())) 43 | (let-values ([(l0 l1 l2) (split-three-at (list "abc" "") 2)]) 44 | (check-equal? l0 '("abc" "")) 45 | (check-equal? l1 '()) 46 | (check-equal? l2 '())) 47 | (let-values ([(l0 l1 l2) (split-three-at (list "abc" "def" "ghi") 2)]) 48 | (check-equal? l0 '("abc" "def")) 49 | (check-equal? l1 '("ghi")) 50 | (check-equal? l2 '()))) 51 | 52 | (: before-this-after (-> (Listof Any) Natural (Values (Listof Any) Any (Listof Any)))) 53 | (define (before-this-after lst pos) 54 | (define-values (l0 l1 l2) (split-three-at lst pos)) 55 | (define l1-elem (if (empty? l1) "" (first l1))) 56 | (values l0 l1-elem l2)) 57 | 58 | (module+ test 59 | (let-values ([(l0 l1 l2) (before-this-after (list "abc" "def") 0)]) 60 | (check-equal? l0 '()) 61 | (check-equal? l1 "abc") 62 | (check-equal? l2 '("def"))) 63 | (let-values ([(l0 l1 l2) (before-this-after (list "abc" "def") 1)]) 64 | (check-equal? l0 '("abc")) 65 | (check-equal? l1 "def") 66 | (check-equal? l2 '())) 67 | (let-values ([(l0 l1 l2) (before-this-after (list "abc" "def") 2)]) 68 | (check-equal? l0 '("abc" "def")) 69 | (check-equal? l1 "") 70 | (check-equal? l2 '()))) 71 | 72 | (: first-middle-last : (All (T) (Listof T) -> (Values T (Listof T) T))) 73 | (define (first-middle-last lst) 74 | (when (< (length lst) 2) (error 'first-middle-last-length-too-small (~a "length = " (length lst)))) 75 | (define f (first lst)) 76 | (define l (last lst)) 77 | (define middle (drop-right (drop lst 1) 1)) 78 | (values f middle l)) 79 | 80 | (module+ test 81 | ;(check-exn exn:fail? (lambda () (first-middle-last (list "abc")))) 82 | (let-values ([(l0 l1 l2) (first-middle-last (list "abc" "def"))]) 83 | (check-equal? l0 "abc") 84 | (check-equal? l1 '()) 85 | (check-equal? l2 "def")) 86 | (let-values ([(l0 l1 l2) (first-middle-last (list "abc" "def" "ghi"))]) 87 | (check-equal? l0 "abc") 88 | (check-equal? l1 '("def")) 89 | (check-equal? l2 "ghi"))) 90 | 91 | ;;; l1 = l3 > l0 = l4 > l2 92 | ;;; l1 l3 values = list-ref pos1/pos2 93 | ;;; if pos1 = pos2, then l3 = l1 94 | (: split-five-at : (All (T) (Listof T) Natural Natural -> (Values (Listof T) (Listof T) (Listof T) (Listof T) (Listof T)))) 95 | (define (split-five-at lst pos1 pos2) 96 | (when (> pos1 pos2) (error 'split-five-at-incorrect-params (~a "pos1=" pos1 " > pos2 = " pos2))) 97 | (when (> pos2 (length lst)) (error 'split-five-at-out-of-bound (~a "index" pos2 " > length" (length lst)))) 98 | (define-values (l0 l1 l234) (split-three-at lst pos1)) 99 | (cond 100 | [(= pos1 pos2) (values l0 l1 '() l1 l234)] 101 | [else 102 | (define pos (cast (- pos2 pos1 1) Natural)) 103 | (define-values (l2 l3 l4) (split-three-at l234 pos)) 104 | (values l0 l1 l2 l3 l4)])) 105 | 106 | (module+ test 107 | (let-values ([(l0 l1 l2 l3 l4) (split-five-at (list "abc" "def") 0 1)]) 108 | (check-equal? l0 '()) 109 | (check-equal? l1 '("abc")) 110 | (check-equal? l2 '()) 111 | (check-equal? l3 '("def")) 112 | (check-equal? l4 '())) 113 | (let-values ([(l0 l1 l2 l3 l4) (split-five-at (list "abc" "def") 0 2)]) 114 | (check-equal? l0 '()) 115 | (check-equal? l1 '("abc")) 116 | (check-equal? l2 '("def")) 117 | (check-equal? l3 '()) 118 | (check-equal? l4 '())) 119 | (let-values ([(l0 l1 l2 l3 l4) (split-five-at (list "abc" "def") 1 2)]) 120 | (check-equal? l0 '("abc")) 121 | (check-equal? l1 '("def")) 122 | (check-equal? l2 '()) 123 | (check-equal? l3 '()) 124 | (check-equal? l4 '())) 125 | (let-values ([(l0 l1 l2 l3 l4) (split-five-at (list "abc" "def" "ghi") 0 2)]) 126 | (check-equal? l0 '()) 127 | (check-equal? l1 '("abc")) 128 | (check-equal? l2 '("def")) 129 | (check-equal? l3 '("ghi")) 130 | (check-equal? l4 '())) 131 | (let-values ([(l0 l1 l2 l3 l4) (split-five-at (list "abc" "def" "ghi") 1 2)]) 132 | (check-equal? l0 '("abc")) 133 | (check-equal? l1 '("def")) 134 | (check-equal? l2 '()) 135 | (check-equal? l3 '("ghi")) 136 | (check-equal? l4 '())) 137 | (let-values ([(l0 l1 l2 l3 l4) (split-five-at (list "abc" "def" "ghi") 2 3)]) 138 | (check-equal? l0 '("abc" "def")) 139 | (check-equal? l1 '("ghi")) 140 | (check-equal? l2 '()) 141 | (check-equal? l3 '()) 142 | (check-equal? l4 '())) 143 | (let-values ([(l0 l1 l2 l3 l4) (split-five-at (list "a" "b" "c" "d" "e" "f" "g" "h" "i") 3 7)]) 144 | (check-equal? l0 '("a" "b" "c")) 145 | (check-equal? l1 '("d")) 146 | (check-equal? l2 '("e" "f" "g")) 147 | (check-equal? l3 '("h")) 148 | (check-equal? l4 '("i")))) 149 | 150 | 151 | (: first-or-empty-string (-> (Listof String) String)) 152 | (define (first-or-empty-string lst) 153 | (if (empty? lst) 154 | "" 155 | (first lst))) 156 | 157 | (: substring-in-range (->* (String Natural) (Natural) String)) 158 | (define (substring-in-range str start [end +inf.0]) 159 | (define len (string-length str)) 160 | (cond 161 | [(> start len) ""] 162 | [else 163 | (substring str start (exact-round (min end len)))])) 164 | 165 | (: before-middle-after (All (T) (Listof T) Natural Natural -> (Values (Listof T) (Listof T) (Listof T)))) 166 | (define (before-middle-after lst pos1 pos2) 167 | (define-values (l12 l3) (split-at lst pos2)) 168 | (define-values (l1 l2) (split-at l12 pos1)) 169 | (values l1 l2 l3) 170 | ) 171 | -------------------------------------------------------------------------------- /controller-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit 4 | (only-in racket/gui/base key-event% key-code-symbol?) 5 | "controller.rkt" "core.rkt") 6 | 7 | (define (execute-key-symbols b lst) 8 | (define controller (new controller% [buffer b])) 9 | (for ([k-s lst]) 10 | (send controller on-char k-s))) 11 | 12 | (define sample-lines 13 | '("Sing, O goddess, the anger" 14 | "of Achilles son" 15 | "of Peleus, that brought")) 16 | 17 | (let ([ b (new-Buffer sample-lines)]) 18 | (execute-key-symbols b (list 'A '\1 '\2)) 19 | (check-equal? (Buffer-lines b) 20 | '("Sing, O goddess, the anger12" 21 | "of Achilles son" 22 | "of Peleus, that brought"))) 23 | 24 | (let ([ b (new-Buffer sample-lines)]) 25 | (execute-key-symbols b (list 'v 26 | 'A 27 | 'release 28 | '\1 29 | ')) 30 | (check-equal? (Buffer-lines b) 31 | '("Sing, O goddess, the anger1" 32 | "of Achilles son" 33 | "of Peleus, that brought"))) 34 | (let ([ b (new-Buffer sample-lines)]) 35 | (execute-key-symbols b (list ' 36 | 'A 37 | 'release ; necessary for set org-lines 38 | '\1 39 | ')) 40 | (check-equal? (Buffer-lines b) 41 | '("S1ing, O goddess, the anger" 42 | "of Achilles son" 43 | "of Peleus, that brought"))) 44 | (let ([ b (new-Buffer sample-lines)]) 45 | (execute-key-symbols b (list '> 46 | '> 47 | 'd 48 | 'd 49 | 'p)) 50 | (check-equal? (Buffer-lines b) 51 | '("of Achilles son" 52 | " Sing, O goddess, the anger" 53 | "of Peleus, that brought"))) 54 | (let ([ b (new-Buffer sample-lines)]) 55 | (execute-key-symbols b (list 'c 56 | 'i 57 | 'w 58 | 'release 59 | '\1 60 | ')) 61 | (check-equal? (Buffer-lines b) 62 | '("1, O goddess, the anger" 63 | "of Achilles son" 64 | "of Peleus, that brought"))) 65 | (let ([ b (new-Buffer sample-lines)]) 66 | (execute-key-symbols b (list 'd 67 | '\2 68 | 'f 69 | '\,)) 70 | (check-equal? (Buffer-lines b) 71 | '(" the anger" 72 | "of Achilles son" 73 | "of Peleus, that brought"))) 74 | (let ([ b (new-Buffer sample-lines)]) 75 | (execute-key-symbols b (list 'd 76 | '\2 77 | 't 78 | '\,)) 79 | (check-equal? (Buffer-lines b) 80 | '(", the anger" 81 | "of Achilles son" 82 | "of Peleus, that brought"))) 83 | (let ([ b (new-Buffer sample-lines)]) 84 | (execute-key-symbols b (list 'd 85 | '\2 86 | 'a 87 | 'W)) 88 | (check-equal? (Buffer-lines b) 89 | '("goddess, the anger" 90 | "of Achilles son" 91 | "of Peleus, that brought"))) 92 | (let ([ b (new-Buffer sample-lines)]) 93 | (execute-key-symbols b (list 'g 94 | ' 95 | '\2 96 | '$ 97 | 'd 98 | 'T 99 | '| | 100 | 'd 101 | 'F 102 | '| | 103 | 'd 104 | 'i 105 | 'w)) 106 | (check-equal? (Buffer-lines b) 107 | '("Sing, O goddess, the anger" 108 | "of " 109 | "of Peleus, that brought"))) 110 | (let ([ b (new-Buffer sample-lines)]) 111 | (execute-key-symbols b (list ' 112 | 'A 113 | 'release 114 | '\1 115 | ' 116 | ' 117 | ' 118 | ' 119 | ' 120 | '\2 121 | ')) 122 | (check-equal? (Buffer-lines b) 123 | '("S21ing, O goddess, the anger" 124 | "of Achilles son" 125 | "of Peleus, that brought")) 126 | (check-equal? (Buffer-cur b) (Point 0 1 1))) 127 | (let ([ b (new-Buffer sample-lines)]) 128 | (execute-key-symbols b (list 'v 129 | 'i 130 | 'w 131 | ' 132 | 'v 133 | 'a 134 | 'W 135 | 'd)) 136 | (check-equal? (Buffer-lines b) 137 | '("O goddess, the anger" 138 | "of Achilles son" 139 | "of Peleus, that brought")) 140 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 141 | (let ([ b (new-Buffer sample-lines)]) 142 | (execute-key-symbols b (list 'v 143 | 'a 144 | ' 145 | 'g 146 | 'g 147 | 'f 148 | '\,)) 149 | (check-equal? (Buffer-cur b) (Point 0 4 4))) 150 | (let ([ b (new-Buffer sample-lines)]) 151 | (execute-key-symbols b (list 'f 152 | 'O 153 | 'R 154 | ' 155 | ' 156 | ' 157 | ' 158 | '\1 159 | '\2 160 | '\4 161 | ' 162 | '\3 163 | ' 164 | '\4 165 | '\5 166 | '\6 167 | ')) 168 | (check-equal? (Buffer-lines b) 169 | '("Sing, O123" 170 | "456s, the anger" 171 | "of Achilles son" 172 | "of Peleus, that brought")) 173 | (check-equal? (Buffer-cur b) (Point 1 2 2))) 174 | (let ([ b (new-Buffer sample-lines)]) 175 | (execute-key-symbols b (list 'g 176 | 'U 177 | 'U)) 178 | (check-equal? (Buffer-lines b) 179 | '("SING, O GODDESS, THE ANGER" 180 | "of Achilles son" 181 | "of Peleus, that brought"))) 182 | (let ([ b (new-Buffer sample-lines)]) 183 | (execute-key-symbols b (list 'g 184 | 'U 185 | 'U 186 | 'u)) 187 | (check-equal? (Buffer-cur b) (Point 0 0 0)) 188 | (check-equal? (Buffer-lines b) 189 | sample-lines) 190 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 191 | 192 | (let ([ b (new-Buffer sample-lines)]) 193 | (execute-key-symbols b (list 'g 194 | 'U 195 | 'U 196 | 'u 197 | ')) 198 | (check-equal? (Buffer-lines b) 199 | '("SING, O GODDESS, THE ANGER" 200 | "of Achilles son" 201 | "of Peleus, that brought")) 202 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 203 | 204 | (let ([ b (new-Buffer sample-lines)]) 205 | (execute-key-symbols b (list 'f 206 | '\, 207 | ' 208 | 'j 209 | 'e 210 | 'V 211 | 'v 212 | 'g 213 | '~)) 214 | (check-equal? (Buffer-lines b) 215 | '("Sing, o GODDESS, THE ANGER" 216 | "OF aCHILLES son" 217 | "of Peleus, that brought")) 218 | (check-equal? (Buffer-cur b) (Point 1 11 11))) 219 | (let ([ b (new-Buffer sample-lines)]) 220 | (execute-key-symbols b (list 'f 221 | 'O 222 | 'v 223 | 'j 224 | 'r 225 | '-)) 226 | (check-equal? (Buffer-lines b) 227 | '("Sing, --------------------" 228 | "-------lles son" 229 | "of Peleus, that brought")) 230 | (check-equal? (Buffer-cur b) (Point 1 7 7))) 231 | (let ([ b (new-Buffer sample-lines)]) 232 | (execute-key-symbols b (list 'f 233 | 'O 234 | 'v 235 | 'j 236 | 'r 237 | '- 238 | 'w 239 | '\.)) 240 | (check-equal? (Buffer-lines b) 241 | '("Sing, --------------------" 242 | "-------lles ---" 243 | "-------us, that brought")) 244 | (check-equal? (Buffer-cur b) (Point 2 7 7))) 245 | 246 | (let ([ b (new-Buffer sample-lines)]) 247 | (execute-key-symbols b (list 'G 248 | 'A 249 | ' 250 | ' 251 | '\2 252 | 'g 253 | 'g 254 | 'x)) 255 | (check-equal? (Buffer-lines b) 256 | '("Sing, O goddess, the anger" "f Achilles son" "of Peleus, that brough")) 257 | (check-equal? (Buffer-cur b) (Point 1 0 0))) 258 | 259 | (let ([ b (new-Buffer sample-lines)]) 260 | (execute-key-symbols b (list 'f 261 | '\, 262 | 'F 263 | 'g 264 | 'T 265 | 'S 266 | 't 267 | 'O 268 | '\; 269 | 'x 270 | '\, 271 | '\.)) 272 | (check-equal? (Buffer-lines b) 273 | '("Sing, goddess, the anger" 274 | "of Achilles son" 275 | "of Peleus, that brought")) 276 | (check-equal? (Buffer-cur b) (Point 0 5 5))) 277 | 278 | (let ([ b (new-Buffer sample-lines)]) 279 | (execute-key-symbols b (list 't 280 | 'O 281 | 'r 282 | ' 283 | 'y 284 | 'y 285 | 'P)) 286 | (check-equal? (Buffer-lines b) 287 | '("Sing," 288 | "O goddess, the anger" 289 | "O goddess, the anger" 290 | "of Achilles son" 291 | "of Peleus, that brought")) 292 | (check-equal? (Buffer-cur b) (Point 1 0 0))) 293 | 294 | (let ([ b (new-Buffer sample-lines)]) 295 | (execute-key-symbols b (list 't 296 | 'O 297 | 'V 298 | ' 299 | 'v 300 | ' 301 | 'o 302 | ' 303 | 'd)) 304 | (check-equal? (Buffer-lines b) 305 | '("Sing, illes son" 306 | "of Peleus, that brought")) 307 | (check-equal? (Buffer-cur b) (Point 0 6 6))) 308 | 309 | (let ([ b (new-Buffer sample-lines)]) 310 | (execute-key-symbols b (list 't 311 | 'O 312 | 'i 313 | ' 314 | ' 315 | ' 316 | 'o 317 | ')) 318 | (check-equal? (Buffer-lines b) 319 | '("Sing O goddess, the anger" 320 | "of A" 321 | "ochilles son" 322 | "of Peleus, that brought")) 323 | (check-equal? (Buffer-cur b) (Point 2 0 0))) 324 | 325 | (require (only-in racket/gui/base the-clipboard)) 326 | (let ([ b (new-Buffer sample-lines)]) 327 | (send the-clipboard set-clipboard-string "123\n456" (current-milliseconds)) 328 | (execute-key-symbols b (list '\2 329 | '$ 330 | 'I 331 | ' 332 | ')) 333 | (check-equal? (Buffer-lines b) 334 | '("Sing, O goddess, the anger" 335 | "123" 336 | "456of Achilles son" 337 | "of Peleus, that brought")) 338 | (check-equal? (Buffer-cur b) (Point 2 2 2))) 339 | 340 | (let ([ b (new-Buffer sample-lines)]) 341 | (execute-key-symbols b (list '\2 342 | 'j 343 | 'w 344 | ' 345 | 'e 346 | 'k 347 | 'A 348 | ': 349 | ')) 350 | (check-equal? (Buffer-lines b) 351 | '("Sing, O goddess, the anger" 352 | "of Achill:es son" 353 | "of Peleus:, that brought")) 354 | (check-equal? (Buffer-cur b) (Point 1 9 9))) 355 | -------------------------------------------------------------------------------- /controller-test1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | (require rackunit 5 | (only-in racket/gui/base key-event% key-code-symbol?) 6 | "controller.rkt" "core.rkt") 7 | 8 | (define (execute-key-symbols b lst) 9 | (define controller (new controller% [buffer b])) 10 | (for ([k-s lst]) 11 | (send controller on-char k-s))) 12 | 13 | (define sample-lines 14 | '("Sing, O goddess, the anger" 15 | "of Achilles son" 16 | "of Peleus, that brought")) 17 | 18 | (let ([ b (new-Buffer sample-lines)]) 19 | (execute-key-symbols b (list '$ 20 | 'x 21 | 'x)) 22 | (check-equal? (Buffer-lines b) 23 | '("Sing, O goddess, the ang" 24 | "of Achilles son" 25 | "of Peleus, that brought")) 26 | (check-equal? (Buffer-cur b) (Point 0 23 +inf.0))) 27 | 28 | (let ([ b (new-Buffer sample-lines)]) 29 | (execute-key-symbols b (list 'o 30 | '\1 31 | ' 32 | 'u)) 33 | (check-equal? (Buffer-lines b) 34 | '("Sing, O goddess, the anger" 35 | "of Achilles son" 36 | "of Peleus, that brought")) 37 | (check-equal? (Buffer-cur b) (Point 0 25 +inf.0))) 38 | (let ([ b (new-Buffer sample-lines)]) 39 | (execute-key-symbols b (list 'o 40 | '\1 41 | ' 42 | 'x)) 43 | (check-equal? (Buffer-lines b) 44 | '("Sing, O goddess, the anger" 45 | "" 46 | "of Achilles son" "of Peleus, that brought")) 47 | (check-equal? (Buffer-cur b) (Point 1 0 0))) 48 | 49 | (let ([ b (new-Buffer sample-lines)]) 50 | (execute-key-symbols b (list 'f 51 | '\, 52 | 'r 53 | ' 54 | 'u)) 55 | (check-equal? (Buffer-lines b) 56 | '("Sing, O goddess, the anger" 57 | "of Achilles son" 58 | "of Peleus, that brought")) 59 | (check-equal? (Buffer-cur b) (Point 0 5 5))) 60 | 61 | (let ([ b (new-Buffer sample-lines)]) 62 | (execute-key-symbols b (list '/ 63 | '\, 64 | ' 65 | 'n 66 | 'n 67 | 'n 68 | 'N)) 69 | (check-equal? (Buffer-lines b) 70 | '("Sing, O goddess, the anger" 71 | "of Achilles son" 72 | "of Peleus, that brought")) 73 | (check-equal? (Buffer-cur b) (Point 2 9 9))) 74 | 75 | (let ([ b (new-Buffer sample-lines)]) 76 | (execute-key-symbols b (list '? 77 | '\, 78 | ' 79 | 'n 80 | 'n 81 | 'n 82 | 'N)) 83 | (check-equal? (Buffer-lines b) 84 | '("Sing, O goddess, the anger" 85 | "of Achilles son" 86 | "of Peleus, that brought")) 87 | (check-equal? (Buffer-cur b) (Point 0 4 4))) 88 | 89 | (let ([ b (new-Buffer sample-lines)]) 90 | (execute-key-symbols b (list 'G 91 | ': 92 | '% 93 | 's 94 | '/ 95 | '/ 96 | ' 97 | 'o 98 | 'f 99 | '/ 100 | 'a 101 | 'n 102 | 'd 103 | '/ 104 | 'g 105 | 'c 106 | ' 107 | 'n 108 | 'y 109 | 'j)) 110 | (check-equal? (Buffer-lines b) 111 | '("Sing, O goddess, the anger" 112 | "of Achilles son" 113 | "and Peleus, that brought")) 114 | (check-equal? (Buffer-cur b) (Point 2 0 0))) 115 | 116 | (let ([ b (new-Buffer sample-lines)]) 117 | (execute-key-symbols b (list 'G 118 | ': 119 | '% 120 | 's 121 | '/ 122 | 'o 123 | 'f 124 | '/ 125 | 'a 126 | 'n 127 | 'd 128 | '/ 129 | 'g 130 | 'c 131 | ' 132 | 'n 133 | 'y 134 | 'j)) 135 | (check-equal? (Buffer-lines b) 136 | '("Sing, O goddess, the anger" 137 | "of Achilles son" 138 | "and Peleus, that brought")) 139 | (check-equal? (Buffer-cur b) (Point 2 0 0))) 140 | (let ([ b (new-Buffer sample-lines)]) 141 | (execute-key-symbols b (list 'G 142 | ': 143 | '% 144 | 's 145 | '/ 146 | 'o 147 | 'f 148 | '/ 149 | 'a 150 | 'n 151 | 'd 152 | '/ 153 | 'g 154 | 'c 155 | ' 156 | 'n 157 | 'a 158 | 'j)) 159 | (check-equal? (Buffer-lines b) 160 | '("Sing, O goddess, the anger" 161 | "of Achilles son" 162 | "and Peleus, that brought")) 163 | (check-equal? (Buffer-cur b) (Point 2 0 0))) 164 | 165 | (let ([ b (new-Buffer sample-lines)]) 166 | (execute-key-symbols b (list 'G 167 | ': 168 | '% 169 | 's 170 | '/ 171 | 'o 172 | 'f 173 | '/ 174 | 'a 175 | 'n 176 | 'd 177 | '/ 178 | 'g 179 | 'c 180 | ' 181 | 'a 182 | 'j)) 183 | (check-equal? (Buffer-lines b) 184 | '("Sing, O goddess, the anger" 185 | "and Achilles son" 186 | "and Peleus, that brought")) 187 | (check-equal? (Buffer-cur b) (Point 2 0 0))) 188 | (let ([ b (new-Buffer sample-lines)]) 189 | (execute-key-symbols b (list ': 190 | '% 191 | 's 192 | 'u 193 | 'b 194 | 's 195 | 't 196 | 'i 197 | 't 198 | 'u 199 | 'd 200 | 'e 201 | '/ 202 | 'o 203 | '/ 204 | 'x 205 | ')) 206 | (check-equal? (Buffer-lines b) 207 | '("Sing, O gxddess, the anger" 208 | "xf Achilles son" 209 | "xf Peleus, that brought")) 210 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 211 | (let ([ b (new-Buffer sample-lines)]) 212 | (execute-key-symbols b (list ': 213 | '% 214 | 's 215 | '/ 216 | 'o 217 | '/ 218 | 'x 219 | '/ 220 | 'g 221 | ')) 222 | (check-equal? (Buffer-lines b) 223 | '("Sing, O gxddess, the anger" 224 | "xf Achilles sxn" 225 | "xf Peleus, that brxught")) 226 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 227 | (let ([ b (new-Buffer sample-lines)]) 228 | (execute-key-symbols b (list ': 229 | '% 230 | 's 231 | '/ 232 | 'o 233 | '/ 234 | 'x 235 | '/ 236 | 'g 237 | ' 238 | 'u)) 239 | (check-equal? (Buffer-lines b) 240 | '("Sing, O goddess, the anger" 241 | "of Achilles son" 242 | "of Peleus, that brought")) 243 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 244 | (let ([ b (new-Buffer sample-lines)]) 245 | (execute-key-symbols b (list ': 246 | '% 247 | 's 248 | '/ 249 | 'o 250 | '/ 251 | 'x 252 | '/ 253 | 'g 254 | 'c 255 | ' 256 | 'y 257 | 'y 258 | 'Y 259 | 'u)) 260 | (check-equal? (Buffer-lines b) 261 | '("Sing, O gxddess, the anger" 262 | "xf Achilles son" 263 | "of Peleus, that brought")) 264 | (check-equal? (Buffer-cur b) (Point 1 0 0))) 265 | (let ([ b (new-Buffer sample-lines)]) 266 | (execute-key-symbols b (list ': 267 | '% 268 | 's 269 | '/ 270 | 'o 271 | '/ 272 | 'x 273 | ' 274 | 'u)) 275 | (check-equal? (Buffer-lines b) 276 | '("Sing, O goddess, the anger" 277 | "of Achilles son" 278 | "of Peleus, that brought")) 279 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 280 | 281 | (let ([ b (new-Buffer '("Sing, O goddess, the anger" 282 | "of Achilles son" 283 | "of Peleus, that brought" 284 | ", the anger" 285 | "of Achilles son"))]) 286 | (execute-key-symbols b (list ': 287 | '% 288 | 's 289 | '/ 290 | 'o 291 | '/ 292 | 'x 293 | ')) 294 | (check-equal? (Buffer-lines b) 295 | '("Sing, O gxddess, the anger" 296 | "xf Achilles son" 297 | "xf Peleus, that brought" 298 | ", the anger" 299 | "xf Achilles son")) 300 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 301 | 302 | (let ([ b (new-Buffer sample-lines)]) 303 | (execute-key-symbols b (list 304 | 'd 305 | 'l)) 306 | (check-equal? (Buffer-lines b) 307 | '("ing, O goddess, the anger" 308 | "of Achilles son" 309 | "of Peleus, that brought")) 310 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 311 | -------------------------------------------------------------------------------- /controller-test2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit 4 | "controller.rkt" "core.rkt") 5 | 6 | (define (execute-key-symbols b lst) 7 | (define controller (new controller% [buffer b])) 8 | (for ([k-s lst]) 9 | (send controller on-char k-s))) 10 | 11 | (define sample-lines 12 | '("Sing, O goddess, the anger" 13 | "of Achilles son" 14 | "of Peleus, that brought")) 15 | 16 | (let ([ b (new-Buffer sample-lines)]) 17 | (execute-key-symbols b (list 'v 18 | '/ 19 | 'f 20 | ' 21 | 'd)) 22 | (check-equal? (Buffer-lines b) 23 | '(" Achilles son" 24 | "of Peleus, that brought"))) 25 | 26 | (let ([ b (new-Buffer sample-lines)]) 27 | (execute-key-symbols b (list 'v 28 | 't 29 | 'O 30 | ' 31 | 'd)) 32 | (check-equal? (Buffer-lines b) 33 | '("O goddess, the anger" 34 | "of Achilles son" 35 | "of Peleus, that brought"))) 36 | 37 | (let ([ b (new-Buffer sample-lines)]) 38 | (execute-key-symbols b (list 'c 39 | '/ 40 | 'P 41 | ' 42 | '\1 43 | '\2 44 | ')) 45 | (check-equal? (Buffer-lines b) 46 | '("12Peleus, that brought"))) 47 | 48 | (let ([ b (new-Buffer sample-lines)]) 49 | (execute-key-symbols b (list 'f 50 | 'O 51 | 'm 52 | 'm 53 | 'j 54 | 'g 55 | 'U 56 | '\` 57 | 'm 58 | )) 59 | (check-equal? (Buffer-lines b) 60 | '("Sing, O GODDESS, THE ANGER" 61 | "OF ACHIlles son" 62 | "of Peleus, that brought"))) 63 | 64 | (let ([ b (new-Buffer sample-lines)]) 65 | (execute-key-symbols b (list 'f 66 | 'O 67 | 'i 68 | '\( 69 | ' 70 | 'j 71 | 'b 72 | 'i 73 | '\) 74 | ' 75 | 'd 76 | '%)) 77 | (check-equal? (Buffer-lines b) 78 | '("Sing, Achilles son" 79 | "of Peleus, that brought"))) 80 | 81 | (let ([ b (new-Buffer sample-lines)]) 82 | (execute-key-symbols b (list 'A 83 | '< 84 | ' 85 | '> 86 | ' 87 | 'd 88 | 'a 89 | '< 90 | )) 91 | (check-equal? (Buffer-lines b) 92 | '("Sing, O goddess, the anger" 93 | "of Peleus, that brought"))) 94 | 95 | (let ([ b (new-Buffer sample-lines)]) 96 | (execute-key-symbols b (list 'f 97 | '\, 98 | 'a 99 | '\{ 100 | '\{ 101 | ' 102 | 'j 103 | 'A 104 | '\} 105 | '\} 106 | ' 107 | 'k 108 | 'd 109 | '\2 110 | 'a 111 | '\} 112 | )) 113 | (check-equal? (Buffer-lines b) 114 | '("Sing," 115 | "of Peleus, that brought"))) 116 | 117 | (let ([ b (new-Buffer sample-lines)]) 118 | (execute-key-symbols b (list 'j 119 | 'f 120 | 'shift 121 | 'A 122 | 'J 123 | 'm 124 | 'm 125 | 'e 126 | 'j 127 | 'd 128 | '\' 129 | 'm)) 130 | (check-equal? (Buffer-lines b) 131 | '("Sing, O goddess, the anger" 132 | "that brought"))) 133 | 134 | (let ([ b (new-Buffer sample-lines)]) 135 | (execute-key-symbols b (list '\1 136 | '\| 137 | 'd 138 | '\2 139 | '\|)) 140 | (check-equal? (Buffer-lines b) 141 | '("ing, O goddess, the anger" 142 | "of Achilles son" 143 | "of Peleus, that brought"))) 144 | 145 | (let ([ b (new-Buffer sample-lines)]) 146 | (execute-key-symbols b (list '? 147 | 'o 148 | 'f 149 | ' 150 | '\# 151 | 'd 152 | '*)) 153 | (check-equal? (Buffer-lines b) 154 | '("Sing, O goddess, the anger" 155 | "of Peleus, that brought"))) 156 | 157 | (let ([ b (new-Buffer sample-lines)]) 158 | (execute-key-symbols b (list '\2 159 | '/ 160 | 'o 161 | 'f 162 | ' 163 | 'd 164 | '\2 165 | 'shift 166 | '*)) 167 | (check-equal? (Buffer-lines b) 168 | '("Sing, O goddess, the anger" 169 | "of Achilles son" 170 | "of Peleus, that brought"))) 171 | 172 | (let ([ b (new-Buffer sample-lines)]) 173 | (execute-key-symbols b (list '\9 174 | '\0 175 | '% 176 | 'd 177 | '\1 178 | '\0 179 | '\0 180 | '%)) 181 | (check-equal? (Buffer-lines b) 182 | '("Sing, O goddess, the anger" 183 | "of Achilles son"))) 184 | 185 | (let ([ b (new-Buffer sample-lines)]) 186 | (execute-key-symbols b (list '/ 187 | 'o 188 | ' 189 | 'd 190 | '\3 191 | '? 192 | ')) 193 | (check-equal? (Buffer-lines b) 194 | '("Sing, O gon" 195 | "of Peleus, that brought"))) 196 | 197 | (let ([ b (new-Buffer sample-lines)]) 198 | (execute-key-symbols b (list 'j 199 | 'f 200 | 'A 201 | 'v 202 | 'e 203 | ' 204 | 'j 205 | '\` 206 | '< 207 | 'd 208 | '\' 209 | '>)) 210 | (check-equal? (Buffer-lines b) 211 | '("Sing, O goddess, the anger" 212 | "chilles son" 213 | "of Peleus, that brought"))) 214 | 215 | (let ([ b (new-Buffer sample-lines)]) 216 | (execute-key-symbols b (list ' 217 | 'j 218 | '\5 219 | 'A 220 | '\1 221 | ')) 222 | (check-equal? (Buffer-lines b) 223 | '("S11111ing, O goddess, the anger" 224 | "o11111f Achilles son" 225 | "of Peleus, that brought"))) 226 | 227 | (let ([ b (new-Buffer sample-lines)]) 228 | (execute-key-symbols b (list '\2 229 | 'l 230 | '\5 231 | 'X)) 232 | (check-equal? (Buffer-lines b) 233 | '("ng, O goddess, the anger" 234 | "of Achilles son" 235 | "of Peleus, that brought"))) 236 | 237 | (let ([ b (new-Buffer sample-lines)]) 238 | (execute-key-symbols b (list 239 | 'q 240 | 'q 241 | 'd 242 | 'w 243 | 'q 244 | 'j 245 | '@ 246 | 'q 247 | 'j 248 | '@ 249 | '@)) 250 | (check-equal? (Buffer-lines b) 251 | '(", O goddess, the anger" 252 | "Achilles son" "Peleus, that brought"))) 253 | 254 | (let ([ b (new-Buffer sample-lines)]) 255 | (execute-key-symbols b (list 'q 256 | 'q 257 | 'x 258 | 'q 259 | 'u 260 | '|2| 261 | '@ 262 | 'q 263 | 'u 264 | 'j 265 | '@ 266 | 'q 267 | 'u 268 | 'h 269 | '|2| 270 | '@ 271 | 'q)) 272 | (check-equal? (Buffer-lines b) 273 | '("Sing, O goddess, the anger" 274 | "ofchilles son" 275 | "of Peleus, that brought"))) 276 | 277 | (let ([ b (new-Buffer sample-lines)]) 278 | (execute-key-symbols b (list '/ 279 | 'o 280 | 'f 281 | '/ 282 | '+ 283 | '|2| 284 | ' 285 | 'x)) 286 | (check-equal? (Buffer-lines b) 287 | '("Sing, O goddess, the anger" 288 | "of Achilles son" 289 | "f Peleus, that brought"))) 290 | 291 | (let ([ b (new-Buffer sample-lines)]) 292 | (execute-key-symbols b (list '? 293 | 'b 294 | '? 295 | '- 296 | '|1| 297 | ' 298 | 'x)) 299 | (check-equal? (Buffer-lines b) 300 | '("Sing, O goddess, the anger" 301 | "f Achilles son" 302 | "of Peleus, that brought"))) 303 | -------------------------------------------------------------------------------- /controller-test3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit 4 | "controller.rkt" "core.rkt") 5 | 6 | (define (execute-key-symbols b lst) 7 | (define controller (new controller% [buffer b])) 8 | (for ([k-s lst]) 9 | (send controller on-char k-s))) 10 | 11 | (define sample-lines 12 | '("Sing, O goddess, the anger" 13 | "of Achilles son" 14 | "of Peleus, that brought")) 15 | 16 | (displayln "Test Substitude") 17 | 18 | (let ([ b (new-Buffer sample-lines)]) 19 | (execute-key-symbols b (list ': 20 | 's 21 | '/ 22 | 'i 23 | '/ 24 | 'o 25 | '/ 26 | 'g 27 | ')) 28 | (check-equal? (Buffer-lines b) 29 | '("Song, O goddess, the anger" 30 | "of Achilles son" 31 | "of Peleus, that brought")) 32 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 33 | 34 | (let ([ b (new-Buffer sample-lines)]) 35 | (execute-key-symbols b (list ': 36 | '\1 37 | '\, 38 | '$ 39 | 's 40 | '/ 41 | 'i 42 | '/ 43 | 'o 44 | '/ 45 | 'g 46 | ')) 47 | (check-equal? (Buffer-lines b) 48 | '("Song, O goddess, the anger" 49 | "of Acholles son" 50 | "of Peleus, that brought")) 51 | (check-equal? (Buffer-cur b) (Point 0 0 0))) 52 | 53 | 54 | (let ([ b (new-Buffer sample-lines)]) 55 | (execute-key-symbols b (list ': 56 | '\2 57 | '|,| 58 | '\3 59 | 's 60 | '/ 61 | 'o 62 | '/ 63 | 'x 64 | '/ 65 | 'c 66 | ' 67 | 'y 68 | 'y 69 | ')) 70 | (check-equal? (Buffer-lines b) 71 | '("Sing, O goddess, the anger" 72 | "xf Achilles son" 73 | "xf Peleus, that brought")) 74 | (check-equal? (Buffer-cur b) (Point 2 0 0))) 75 | 76 | 77 | (let ([ b (new-Buffer sample-lines)]) 78 | (execute-key-symbols b (list ': 79 | '/ 80 | 's 81 | 'o 82 | 'n 83 | '/ 84 | '|,| 85 | '$ 86 | 's 87 | '/ 88 | 'o 89 | '/ 90 | 'x 91 | '/ 92 | 'g 93 | 'c 94 | ' 95 | 'y 96 | 'y 97 | 'y 98 | 'n)) 99 | (check-equal? (Buffer-lines b) 100 | '("Sing, O goddess, the anger" 101 | "xf Achilles sxn" 102 | "xf Peleus, that brought")) 103 | (check-equal? (Buffer-cur b) (Point 2 18 18))) 104 | 105 | (let ([ b (new-Buffer sample-lines)]) 106 | (execute-key-symbols b (list ': 107 | '|,| 108 | '? 109 | 's 110 | 'o 111 | 'n 112 | '? 113 | 's 114 | '/ 115 | 'o 116 | '/ 117 | 'x 118 | '/ 119 | 'g 120 | 'c 121 | ' 122 | 'y 123 | 'n 124 | 'a)) 125 | (check-equal? (Buffer-lines b) 126 | '("Sing, O gxddess, the anger" 127 | "of Achilles sxn" 128 | "of Peleus, that brought")) 129 | (check-equal? (Buffer-cur b) (Point 1 13 13))) 130 | 131 | (let ([ b (new-Buffer sample-lines)]) 132 | (execute-key-symbols b (list 'j 133 | 'f 134 | 'l 135 | 'v 136 | 'j 137 | ': 138 | 's 139 | '/ 140 | 'o 141 | '/ 142 | 'x 143 | '/ 144 | 'g 145 | 'c 146 | ' 147 | 'y 148 | 'y 149 | 'n 150 | 'a)) 151 | (check-equal? (Buffer-lines b) 152 | '("Sing, O goddess, the anger" 153 | "xf Achilles sxn" 154 | "of Peleus, that brxught")) 155 | (check-equal? (Buffer-cur b) (Point 2 18 18))) 156 | -------------------------------------------------------------------------------- /controller.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require "mode.rkt" "core.rkt" "diff-manager.rkt" "reg-manager.rkt" "macro-recorder.rkt") 6 | 7 | (define mode-switcher% 8 | (class object% 9 | (super-new) 10 | (define current-mode (new normal-mode%)) 11 | (define/public (get-current-mode) 12 | current-mode) 13 | (define/public (enter-mode! mode) 14 | (set! current-mode mode)))) 15 | 16 | (define controller% 17 | (class object% 18 | (super-new) 19 | [init-field buffer] 20 | (define mode-switcher (new mode-switcher%)) 21 | (define diff-manager (new diff-manager%)) 22 | (define reg-manager (new reg-manager%)) 23 | (define macro-recorder (new macro-recorder% [controller this])) 24 | (define/public (get-buffer) 25 | buffer) 26 | (define/public (on-char key-symbol) 27 | (send macro-recorder record! key-symbol) 28 | (define current-mode (send mode-switcher get-current-mode)) 29 | (send current-mode on-char key-symbol buffer mode-switcher diff-manager reg-manager macro-recorder)) 30 | (define/public (draw-points dc start-row) 31 | (define current-mode (send mode-switcher get-current-mode)) 32 | (send current-mode draw-points dc buffer start-row)) 33 | (define/public (get-status-line) 34 | (define current-mode (send mode-switcher get-current-mode)) 35 | (send current-mode get-status-line)) 36 | )) 37 | 38 | -------------------------------------------------------------------------------- /core.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (module+ test (require typed/rackunit)) 4 | 5 | (provide (all-defined-out)) 6 | 7 | ;;; 8 | ;;; REPRENSENTATION 9 | ;;; 10 | 11 | ;(struct line (string length) #:transparent #:mutable) 12 | 13 | ; (struct lines (lines) #:transparent #:mutable) 14 | ; A lines being edited is represented as a list of lines. 15 | 16 | (define-type Lines (Listof String)) 17 | 18 | (struct Buffer ([lines : Lines] [path : (Option String)] [cur : Point] [modified? : Boolean]) 19 | #:transparent #:mutable) 20 | 21 | ; A Buffer is the basic unit of lines being edited. 22 | ; It contains a lines being edited. 23 | ; The Buffer has a name, so the user can refer to the Buffer. 24 | ; The Buffer might have an associated file: 25 | ; path = #f <=> Buffer is not associated with a file 26 | ; path = path <=> reads and writes to the file given by the path 27 | ; A Point is a position between two characters. 28 | ; Insertions and deletion will happen at the Points (usually only one). 29 | ; If modified? is true, then the Buffer has been modied since the last 30 | ; read or save of the file. 31 | 32 | (struct Point ([row : Natural] [col : Natural] [max-col : (U Natural '+inf.0)]) #:transparent) 33 | ; A Point rembers a position in the lines. 34 | 35 | (module+ test 36 | (define illead-lines 37 | (list "Sing, O goddess, the anger of Achilles son of Peleus, that brought" 38 | "countless ills upon the Achaeans. Many a brave soul did it send hurrying" 39 | "down to Hades, and many a hero did it yield a prey to dogs and vultures," 40 | "for so were the counsels of Jove fulfilled from the day on which the" 41 | "son of Atreus, king of men, and great Achilles, first fell out with" 42 | "one another.")) 43 | 44 | ; recreate the same lines file from scratch 45 | #; (define (create-new-test-file path) 46 | (with-output-to-file path 47 | (λ() (for ([line illead-lines]) 48 | (displayln line))) 49 | #:exists 'replace))) 50 | 51 | ;;; 52 | ;;; lines 53 | ;;; 54 | 55 | ; path->lines : path -> lines 56 | ; create a lines with contents from the file given by path 57 | (: path->lines (-> String Lines)) 58 | (define (path->lines path) 59 | (with-input-from-file path 60 | (λ () (for/list : Lines ([l (in-lines)]) l)))) 61 | 62 | #;(module+ test 63 | (void (create-new-test-file "illead.txt")) 64 | (check-equal? (path->lines "illead.txt") illead-lines)) 65 | 66 | ;;; 67 | ;;; Point 68 | ;;; 69 | 70 | ; Point-row-col : Point -> integer integer 71 | ; return row and column number for the Point m in the Buffer b 72 | (: Point-row-col (Point -> (Values Natural Natural))) 73 | (define (Point-row-col m) 74 | (values (Point-row m) (Point-col m))) 75 | 76 | ;;; 77 | ;;; BUFFER 78 | ;;; 79 | 80 | ; new-Buffer : -> Buffer 81 | ; create fresh Buffer without an associated file 82 | (: new-Buffer (->* () (Lines (Option String)) Buffer)) 83 | (define (new-Buffer [lines '()] [path #f]) 84 | (define p (Point 0 0 0)) 85 | (define modified? #f) 86 | (Buffer lines path p modified?)) 87 | 88 | ; save-Buffer : Buffer -> void 89 | ; save contents of Buffer to associated file 90 | ; do nothing if no file is associated 91 | (: save-Buffer! (-> Buffer Void)) 92 | (define (save-Buffer! b) 93 | (define file (Buffer-path b)) 94 | (when file 95 | (with-output-to-file file 96 | (λ () (for ([line (Buffer-lines b)]) 97 | (displayln line))) 98 | #:exists 'replace) 99 | (set-Buffer-modified?! b #f))) 100 | 101 | (module+ test 102 | (provide illead-Buffer) 103 | (define illead-Buffer (new-Buffer illead-lines "illead.txt")) 104 | (save-Buffer! illead-Buffer) 105 | (check-equal? (path->lines "illead.txt") illead-lines)) 106 | 107 | ; read-Buffer : Buffer -> void 108 | ; replace lines of Buffer with file contents 109 | #;(define (read-Buffer! b) 110 | (define path (Buffer-path b)) 111 | (unless path (error 'read-Buffer "no assoiated file: ~a" b)) 112 | (define lines (path->lines path)) 113 | (set-Buffer-lines! b lines) 114 | (set-Buffer-modified?! b #f)) 115 | 116 | #;(module+ test 117 | (void (create-new-test-file "illead.txt")) 118 | (define b (new-Buffer '() "illead.txt")) 119 | (read-Buffer! b) 120 | (check-equal? b illead-Buffer)) 121 | 122 | ; append-to-Buffer-from-file : Buffer path -> void 123 | ; append contents of file given by the path p to the lines of the Buffer b 124 | #;(define (append-to-Buffer-from-file b p) 125 | (define lines-to-append (path->lines p)) 126 | (set-Buffer-lines! b (append (Buffer-lines b) lines-to-append)) 127 | (set-Buffer-modified?! b #t)) 128 | 129 | #;(module+ test 130 | (void (create-new-test-file "illead.txt")) 131 | (define append-Buffer (new-Buffer '())) 132 | (append-to-Buffer-from-file append-Buffer "illead.txt") 133 | (append-to-Buffer-from-file append-Buffer "illead.txt") 134 | (save-Buffer! b) ; make sure the Buffer is unmodified before comparison 135 | (check-equal? (Buffer-lines append-Buffer) (append illead-lines illead-lines))) 136 | 137 | (: Buffer-display (-> Buffer Void)) 138 | (define (Buffer-display b) 139 | (define (line-display {l : String}) 140 | (displayln l)) 141 | (define (lines-display {t : Lines}) 142 | (for ([l t]) 143 | (line-display l))) 144 | (lines-display (Buffer-lines b))) 145 | 146 | #;(module+ test 147 | (Buffer-display illead-Buffer)) 148 | 149 | (: Buffer-substring-at (-> Buffer Natural Natural Natural String)) 150 | (define (Buffer-substring-at b row col0 col1) 151 | (define l (list-ref (Buffer-lines b) row)) 152 | (if (>= (string-length l) col1) 153 | (substring l col0 col1) 154 | " ")) 155 | 156 | 157 | (: line-ref-char (-> String Natural Char)) 158 | (define (line-ref-char l col) 159 | (if (> (string-length l) col) 160 | (string-ref l col) 161 | #\space)) 162 | 163 | (module+ test 164 | (check-equal? (line-ref-char "abc" 0) #\a) 165 | (check-equal? (line-ref-char "abc" 1) #\b) 166 | (check-equal? (line-ref-char "abc" 2) #\c) 167 | (check-equal? (line-ref-char "abc" 3) #\space)) 168 | 169 | (: Point Point Point Boolean)) 170 | (define (Point Point Point Point)) 185 | (define (min-Point p1 p2) 186 | (if (Point Lines Boolean)) 194 | (define (empty-lines? lines) 195 | (or (empty? lines) (equal? lines '("")))) 196 | -------------------------------------------------------------------------------- /diff-manager.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "diff.rkt" 4 | "wrapped-move-scope.rkt") 5 | 6 | (module+ test 7 | (require rackunit)) 8 | 9 | (provide diff-manager%) 10 | 11 | ; (: empty-diff? (-> Diff-item Boolean)) 12 | (define (empty-diff? diff) 13 | (match-define (Diff-item old-region new-region) diff) 14 | (match-define (Region old-scope old-lines) old-region) 15 | (match-define (Region new-scope new-lines) new-region) 16 | (define empty-lines? (andmap empty? (list old-lines new-lines))) 17 | (cond 18 | [empty-lines? 19 | (andmap empty-scope? (list old-scope new-scope))] 20 | [(equal-scope? old-scope new-scope) (equal? old-lines new-lines)] 21 | [else #f])) 22 | 23 | (module+ test 24 | (let ([scope1 (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'char)] 25 | [scope2 (Scope (Point 0 1 1) (Point 0 1 1) #t #t 'char)] 26 | [scope3 (Scope (Point 0 2 2) (Point 0 2 2) #t #f 'char)]) 27 | (define region1-0 (Region scope1 '())) 28 | (define region1-1 (Region scope1 '("1"))) 29 | (define region2-0 (Region scope2 '())) 30 | (define region2-1 (Region scope2 '("2"))) 31 | (define region3-0 (Region scope3 '())) 32 | (check-equal? (empty-diff? (Diff-item region1-0 region1-0)) #t) 33 | (check-equal? (empty-diff? (Diff-item region1-0 region3-0)) #t) 34 | (check-equal? (empty-diff? (Diff-item region1-0 region1-1)) #f) 35 | (check-equal? (empty-diff? (Diff-item region2-0 region2-0)) #f) 36 | (check-equal? (empty-diff? (Diff-item region2-0 region2-1)) #f) 37 | (check-equal? (empty-diff? (Diff-item region2-1 region2-1)) #t))) 38 | 39 | (define diff-manager% 40 | (class object% 41 | (super-new) 42 | (define diff-index 0) 43 | ;(new (old)) 44 | (define diff-stack '()) 45 | 46 | (define/public (push-diffs! diff-lst) 47 | (when (not (andmap empty-diff? diff-lst)) 48 | (set! diff-stack (cons diff-lst (drop diff-stack diff-index))) 49 | (set! diff-index 0))) 50 | 51 | ;(: undo-last (-> (Listof String) (Values (Option Point) (Option (Listof String))))) 52 | (define/public (undo-last lines) 53 | (cond 54 | [(< diff-index (length diff-stack)) 55 | (set! diff-index (add1 diff-index)) 56 | (undo-diffs (list-ref diff-stack (sub1 diff-index)) lines)] 57 | [else 58 | (values #f #f)])) 59 | 60 | ;(: redo-next (-> (Listof String) (Values (Option Point) (Option (Listof String))))) 61 | (define/public (redo-next lines) 62 | (cond 63 | [(> diff-index 0) 64 | (set! diff-index 65 | (sub1 diff-index)) 66 | (redo-diffs (list-ref diff-stack diff-index) lines)] 67 | [else 68 | (values #f lines)])) 69 | 70 | (define/public (diff-stack-len-index) 71 | (- (length diff-stack) diff-index)) 72 | 73 | (define/public (combine-since! len) 74 | (unless (= diff-index 0) (error 'diff-index-not-0)) 75 | (define-values (after before) (split-at-right diff-stack len)) 76 | (set! diff-stack (cons (flatten after) before))) 77 | )) -------------------------------------------------------------------------------- /diff-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide get-delete-diffs get-insert-diffs get-replace-diffs get-right-shift-diffs get-left-shift-diffs (struct-out Diff-item) (struct-out Region)) 4 | 5 | (require "core.rkt" "move.rkt" "wrapped-move-scope.rkt" "change.rkt" "diff.rkt") 6 | 7 | (module+ test (require rackunit)) 8 | 9 | (define (get-deleted-region old-scope lines) 10 | (define deleted-lines (Scoped-lines old-scope lines)) 11 | (Region old-scope deleted-lines)) 12 | 13 | (define (get-delete-diffs old-scope lines) 14 | (define old-region (get-deleted-region old-scope lines)) 15 | (match-define (Scope start end _ _ mode) old-scope) 16 | (define new-end (if (equal? mode 'block) 17 | (struct-copy Point start [row (Point-row end)]) 18 | start)) 19 | (define new-region (Region (Scope start new-end #t #f mode) '())) 20 | (list (Diff-item old-region new-region))) 21 | 22 | (module+ test 23 | (check-equal? (get-delete-diffs (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '("")) 24 | (list 25 | (Diff-item 26 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()) 27 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '())))) 28 | (check-equal? (get-delete-diffs (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'char) '("abc")) 29 | (list 30 | (Diff-item 31 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'char) '("a")) 32 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '())))) 33 | (check-equal? (get-delete-diffs (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'line) '("abc")) 34 | (list 35 | (Diff-item 36 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'line) '()) 37 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'line) '())))) 38 | (check-equal? (get-delete-diffs (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'char) '("abc")) 39 | (list 40 | (Diff-item 41 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'char) '("a")) 42 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '())))) 43 | 44 | (check-equal? (get-delete-diffs (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'char) '("abc" "def")) 45 | (list 46 | (Diff-item 47 | (Region (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'char) '("bc" "d")) 48 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'char) '())))) 49 | (check-equal? (get-delete-diffs (Scope (Point 0 1 1) (Point 1 1 1) #t #t 'char) '("abc" "def")) 50 | (list 51 | (Diff-item 52 | (Region (Scope (Point 0 1 1) (Point 1 1 1) #t #t 'char) '("bc" "de")) 53 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'char) '())))) 54 | (check-equal? (get-delete-diffs (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'line) '("abc" "def")) 55 | (list 56 | (Diff-item 57 | (Region (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'line) '("abc")) 58 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'line) '())))) 59 | (check-equal? (get-delete-diffs (Scope (Point 0 1 1) (Point 1 1 1) #t #t 'char) '("abc" "def")) 60 | (list 61 | (Diff-item 62 | (Region (Scope (Point 0 1 1) (Point 1 1 1) #t #t 'char) '("bc" "de")) 63 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'char) '()))))) 64 | 65 | (define (get-insert-region start inserted-lines mode) 66 | (define end (after-lines-point start inserted-lines mode)) 67 | (define new-scope (Scope start end #t #f mode)) 68 | (Region new-scope inserted-lines)) 69 | 70 | (module+ test 71 | (check-equal? (get-insert-region (Point 0 0 0) '("1") 'block) 72 | (Region (Scope (Point 0 0 0) (Point 0 1 1) #t #f 'block) '("1")))) 73 | 74 | (define (get-insert-diffs start inserted-lines mode) 75 | (define new-region (get-insert-region start inserted-lines mode)) 76 | (define old-region (Region (Scope start start #t #f mode) '())) 77 | (list (Diff-item old-region new-region))) 78 | 79 | (module+ test 80 | (check-equal? (get-insert-diffs (Point 0 0 0) '("123") 'char) 81 | (list 82 | (Diff-item 83 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()) 84 | (Region (Scope (Point 0 0 0) (Point 0 3 3) #t #f 'char) '("123"))))) 85 | (check-equal? (get-insert-diffs (Point 0 2 2) '("123") 'char) 86 | (list 87 | (Diff-item 88 | (Region (Scope (Point 0 2 2) (Point 0 2 2) #t #f 'char) '()) 89 | (Region (Scope (Point 0 2 2) (Point 0 5 5) #t #f 'char) '("123"))))) 90 | (check-equal? (get-insert-diffs (Point 0 0 0) '("123") 'line) 91 | (list 92 | (Diff-item 93 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'line) '()) 94 | (Region (Scope (Point 0 0 0) (Point 1 0 0) #t #f 'line) '("123"))))) 95 | (check-equal? (get-insert-diffs (Point 0 2 2) '("123") 'line) 96 | (list 97 | (Diff-item 98 | (Region (Scope (Point 0 2 2) (Point 0 2 2) #t #f 'line) '()) 99 | (Region (Scope (Point 0 2 2) (Point 1 0 0) #t #f 'line) '("123"))))) 100 | 101 | (check-equal? (get-insert-diffs (Point 0 1 1) '("123" "456" "789") 'char) 102 | (list 103 | (Diff-item 104 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'char) '()) 105 | (Region 106 | (Scope (Point 0 1 1) (Point 2 3 3) #t #f 'char) 107 | '("123" "456" "789"))))) 108 | (check-equal? (get-insert-diffs (Point 0 2 2) '("123" "456") 'char) 109 | (list 110 | (Diff-item 111 | (Region (Scope (Point 0 2 2) (Point 0 2 2) #t #f 'char) '()) 112 | (Region (Scope (Point 0 2 2) (Point 1 3 3) #t #f 'char) '("123" "456"))))) 113 | (check-equal? (get-insert-diffs (Point 0 1 1) '("123" "") 'line) 114 | 115 | (list 116 | (Diff-item 117 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'line) '()) 118 | (Region (Scope (Point 0 1 1) (Point 2 0 0) #t #f 'line) '("123" ""))))) 119 | (check-equal? (get-insert-diffs (Point 1 2 2) '("" "456") 'line) 120 | (list 121 | (Diff-item 122 | (Region (Scope (Point 1 2 2) (Point 1 2 2) #t #f 'line) '()) 123 | (Region (Scope (Point 1 2 2) (Point 3 0 0) #t #f 'line) '("" "456")))))) 124 | 125 | 126 | (define (get-replace-diffs old-scope new-start inserted-lines mode lines) 127 | (define new-region (get-insert-region new-start inserted-lines mode)) 128 | (define old-region (get-deleted-region old-scope lines)) 129 | (list (Diff-item old-region new-region))) 130 | 131 | (module+ test 132 | (check-equal? (get-replace-diffs (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'char) (Point 0 1 1) '("3") 'char '("abcd" "efg")) 133 | (list 134 | (Diff-item 135 | (Region (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'char) '("bcd" "e")) 136 | (Region (Scope (Point 0 1 1) (Point 0 2 2) #t #f 'char) '("3")))))) 137 | 138 | (define (get-right-shift-diff row) 139 | (define start (line-start-point row)) 140 | (define old-scope (Scope start start #t #f 'char)) 141 | (define old-region (Region old-scope '())) 142 | (define new-end (Point row shift-width shift-width)) 143 | (define new-scope (Scope start new-end #t #f 'char)) 144 | (define new-region (Region new-scope (list (make-indention)))) 145 | (Diff-item old-region new-region)) 146 | 147 | (define (get-right-shift-diffs scope lines) 148 | (match-define (Scope (Point row1 _ _) (Point row2 _ _) _ _ _) scope) 149 | (cond 150 | [(empty? lines) (error 'empty-lines-for-right-shift)] 151 | [else 152 | (define-values (before-middle after) (split-at lines (add1 row2))) 153 | (define-values (before middle) (split-at before-middle row1)) 154 | (define diffs 155 | (for/list 156 | ([i (in-range row1 (add1 row2))]) 157 | (get-right-shift-diff i))) 158 | diffs])) 159 | 160 | (module+ test 161 | (check-equal? (get-right-shift-diffs (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'char) '("abcd" "efg")) 162 | (list (Diff-item (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()) 163 | (Region (Scope (Point 0 0 0) (Point 0 4 4) #t #f 'char) '(" "))) 164 | (Diff-item (Region (Scope (Point 1 0 0) (Point 1 0 0) #t #f 'char) '()) 165 | (Region (Scope (Point 1 0 0) (Point 1 4 4) #t #f 'char) '(" ")))))) 166 | 167 | (define (get-left-shift-diff row l) 168 | (define start (line-start-point row)) 169 | (define end-col (left-shift-line-drop-length l)) 170 | (define end (Point row end-col end-col)) 171 | (define old-scope (Scope start end #t #f 'char)) 172 | (define old-region (Region old-scope (list (substring l 0 end-col)))) 173 | (define ^-p (^-point row l)) 174 | (define new-col (- (Point-col ^-p) end-col)) 175 | (define new-start (Point row new-col new-col)) 176 | (define new-scope (Scope new-start new-start #t #f 'char)) 177 | (define new-region (Region new-scope '())) 178 | (Diff-item old-region new-region)) 179 | 180 | (define (get-left-shift-diffs scope lines) 181 | ;(displayln (~e 'get-left-shift-diffs scope lines)) 182 | (match-define (Scope (Point row1 _ _) (Point row2 _ _) _ _ _) scope) 183 | (cond 184 | [(empty? lines) (error 'empty-lines-for-right-shift)] 185 | [else 186 | (define-values (before-middle after) (split-at lines (add1 row2))) 187 | (define-values (before middle) (split-at before-middle row1)) 188 | (define diffs 189 | (for/list 190 | ([i (in-range row1 (add1 row2))] 191 | [l middle]) 192 | (get-left-shift-diff i l))) 193 | diffs])) 194 | 195 | (module+ test 196 | (check-equal? 197 | (get-left-shift-diffs (Scope (Point 0 1 1) (Point 1 1 1) #t #f 'char) '(" abcd" " efg")) 198 | (list 199 | (Diff-item 200 | (Region (Scope (Point 0 0 0) (Point 0 2 2) #t #f 'char) '(" ")) 201 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '())) 202 | (Diff-item 203 | (Region (Scope (Point 1 0 0) (Point 1 4 4) #t #f 'char) '(" ")) 204 | (Region (Scope (Point 1 1 1) (Point 1 1 1) #t #f 'char) '()))))) 205 | -------------------------------------------------------------------------------- /diff.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | (require "core.rkt" "change.rkt" "wrapped-move-scope.rkt") 3 | 4 | (provide (all-defined-out)) 5 | 6 | (module+ test (require typed/rackunit)) 7 | 8 | (struct Region ([scope : Scope] [lines : (Listof String)]) #:transparent) 9 | 10 | (struct Diff-item ([old-region : Region] [new-region : Region]) #:transparent) 11 | 12 | (define-type Diff-items (Listof Diff-item)) 13 | 14 | (: undo (-> Diff-item (Listof String) (Values Point (Listof String)))) 15 | (define (undo diff lines) 16 | (match-define (Diff-item old new) diff) 17 | (define new-scope (Region-scope new)) 18 | (define old-lines (Region-lines old)) 19 | (replace-scope new-scope lines old-lines)) 20 | 21 | (: undo-diffs (-> Diff-items (Listof String) (Values Point (Listof String)))) 22 | (define (undo-diffs diff-lst lines) 23 | (for/fold 24 | ([_ (Point 0 0 0)] 25 | [ls lines]) 26 | ([d diff-lst]) 27 | (undo d ls))) 28 | 29 | (module+ test 30 | (let* ([old-scope (Scope (Point 0 0 0) (Point 1 0 0) #t #f 'char)] 31 | [new-scope (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char)] 32 | [old-region (Region old-scope '("123"))] 33 | [new-region (Region new-scope '())] 34 | [diff (Diff-item old-region new-region)]) 35 | (let-values ([(p lines) (undo diff (list "abc"))]) 36 | (check-equal? p (Point 0 3 3)) 37 | (check-equal? lines '("123abc")))) 38 | (let* ([old-scope (Scope (Point 0 0 0) (Point 1 0 0) #t #f 'char)] 39 | [new-scope (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char)] 40 | [old-region (Region old-scope '("123" ""))] 41 | [new-region (Region new-scope '())] 42 | [diff (Diff-item old-region new-region)]) 43 | (let-values ([(p lines) (undo diff (list "abc" ""))]) 44 | (check-equal? p (Point 1 0 0)) 45 | (check-equal? lines '("123" "abc" "")))) 46 | (let ([diff (Diff-item 47 | (Region (Scope (Point 2 11 11) (Point 2 11 11) #t #f 'char) 48 | '()) 49 | (Region (Scope (Point 2 11 11) (Point 3 19 19) #t #f 'char) 50 | '("123" "this is a new line ")))]) 51 | (let-values ([(p lines) (undo diff (list "abc" "def" "abcdefghijk123" "this is a new line "))]) 52 | (check-equal? p (Point 2 11 11)) 53 | (check-equal? lines'("abc" "def" "abcdefghijk"))))) 54 | 55 | 56 | (: invert-diff (-> Diff-item Diff-item)) 57 | (define (invert-diff diff) 58 | (match-define (Diff-item old new) diff) 59 | (Diff-item new old)) 60 | 61 | (: redo (-> Diff-item (Listof String) (Values Point (Listof String)))) 62 | (define (redo diff lines) 63 | (undo (invert-diff diff) lines)) 64 | 65 | (: redo-diffs (-> Diff-items (Listof String) (Values Point (Listof String)))) 66 | (define (redo-diffs diff-lst lines) 67 | ;(displayln (~e 'redo-diffs diff-lst lines)) 68 | (for/fold 69 | ([_ (Point 0 0 0)] 70 | [ls lines]) 71 | ([d (reverse diff-lst)]) 72 | (redo d ls))) 73 | 74 | (module+ test 75 | (let ([diff (Diff-item 76 | (Region (Scope (Point 2 11 11) (Point 2 11 11) #t #f 'char) 77 | '()) 78 | (Region (Scope (Point 2 11 11) (Point 3 19 19) #t #f 'char) 79 | '("123" "this is a new line ")))]) 80 | (let-values ([(p lines) (redo diff '("abc" "def" "abcdefghijk"))]) 81 | (check-equal? p (Point 3 19 19)) 82 | (check-equal? lines '("abc" "def" "abcdefghijk123" "this is a new line "))) 83 | (let-values ([(p0 lines0) (redo diff '("abc" "def" "abcdefghijk"))]) 84 | (let-values ([(p1 lines1) (undo diff lines0)]) 85 | (check-equal? p1 (Point 2 11 11)) 86 | (check-equal? lines1 '("abc" "def" "abcdefghijk")))))) 87 | 88 | (module+ test 89 | (let ([diffs (list 90 | (Diff-item 91 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()) 92 | (Region (Scope (Point 0 0 0) (Point 0 4 4) #t #f 'char) '(" "))))]) 93 | (let-values ([(p lines) (undo-diffs diffs '(" abc" "def" "abcdefghijk"))]) 94 | (check-equal? p (Point 0 0 0)) 95 | (check-equal? lines '("abc" "def" "abcdefghijk"))) 96 | (let-values ([(p lines) (redo-diffs diffs '("abc" "def" "abcdefghijk"))]) 97 | (check-equal? p (Point 0 4 4)) 98 | (check-equal? lines '(" abc" "def" "abcdefghijk"))) 99 | (let-values ([(p0 lines0) (redo-diffs diffs '("abc" "def" "abcdefghijk"))]) 100 | (let-values ([(p1 lines1) (undo-diffs diffs lines0)]) 101 | (check-equal? p1 (Point 0 0 0)) 102 | (check-equal? lines1 '("abc" "def" "abcdefghijk")))))) 103 | 104 | 105 | (module+ test 106 | (let ([diffs (list (Diff-item 107 | (Region (Scope (Point 0 3 +inf.0) (Point 0 3 +inf.0) #t #t 'char) '("t")) 108 | (Region (Scope (Point 0 3 +inf.0) (Point 0 3 +inf.0) #t #f 'char) '())))]) 109 | (let-values ([(p lines) (undo-diffs diffs '("abc" "def"))]) 110 | (check-equal? p (Point 0 4 4)) 111 | (check-equal? lines '("abct" "def"))) 112 | (let-values ([(p lines) (redo-diffs diffs '("abct" "def"))]) 113 | (check-equal? p (Point 0 3 +inf.0)) 114 | (check-equal? lines '("abc" "def"))))) 115 | 116 | (module+ test 117 | (let ([diffs 118 | (list (Diff-item 119 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'line) '()) 120 | (Region (Scope (Point 0 0 0) (Point 1 0 0) #t #f 'line) '("Sing"))))]) 121 | (let-values ([(p lines) (redo-diffs diffs '("abc" "def"))]) 122 | (check-equal? p (Point 0 0 0)) 123 | (check-equal? lines '("Sing" "abc" "def"))) 124 | (let-values ([(p lines) (undo-diffs diffs '("Sing" "abc" "def"))]) 125 | (check-equal? p (Point 0 0 0)) 126 | (check-equal? lines '("abc" "def"))))) 127 | 128 | (module+ test 129 | (let ([diffs 130 | (list (Diff-item (Region (Scope (Point 1 7 7) (Point 2 19 19) #t #t 'block) 131 | '("Atreus, " "ther.")) 132 | (Region (Scope (Point 1 7 7) (Point 2 19 19) #t #f 'block) 133 | '("ATREUS, " "THER."))))]) 134 | (let-values ([(p lines) (undo-diffs diffs '("for so were the" "son of ATREUS, " "one anoTHER."))]) 135 | (check-equal? p (Point 1 7 7)) 136 | (check-equal? lines '("for so were the" "son of Atreus, " "one another."))))) 137 | -------------------------------------------------------------------------------- /draw-line.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | 4 | (require "core.rkt" "mode-base.rkt") 5 | 6 | ;;; 7 | ;;; LINES 8 | ;;; 9 | 10 | ; The size of a line is the same as the font size plus one. 11 | (define (line-size) 12 | (define multiplier 13 | ; see https://docs.racket-lang.org/gui/windowing-overview.html#%28part._display-resolution%29 14 | (case (system-type) 15 | [(macosx) 1] 16 | [(unix window) 96/72] 17 | [else 1])) 18 | (define font-size 16) ; 19 | (inexact->exact (floor (+ 1 (* multiplier font-size))))) 20 | 21 | (define line-cursor-mode% 22 | (class mode% 23 | (super-new) 24 | (define/override (draw-points dc b start-row) 25 | (define-values (font-width font-height _ __) (send dc get-text-extent "M")) 26 | (define p (Buffer-cur b)) 27 | (define-values (r c) (Point-row-col p)) 28 | (define x (* c font-width)) 29 | (define line-height (line-size)) 30 | (define y (* (- r start-row) line-height)) 31 | (send dc draw-line x y x (+ y line-height))))) 32 | 33 | (define block-cursor-mode% 34 | (class mode% 35 | (super-new) 36 | (define/override (draw-points dc b start-row) 37 | (send dc set-text-mode 'solid) 38 | (send dc set-text-background "black") 39 | (send dc set-text-foreground "white") 40 | (define-values (font-width font-height _ __) (send dc get-text-extent "M")) 41 | (define p (Buffer-cur b)) 42 | ;(displayln (list 'draw-points 'p p)) 43 | (define-values (r c) (Point-row-col p)) 44 | (define x (* c font-width)) 45 | (define line-height (line-size)) 46 | (define y (* (- r start-row) line-height)) 47 | (define l (list-ref (Buffer-lines b) r)) 48 | (define Point-char (line-ref-char l c)) 49 | (send dc draw-text (string Point-char) x y)))) 50 | 51 | (define visual-mode-base% 52 | (class mode% 53 | (super-new) 54 | (abstract get-scope) 55 | (define/override (draw-points dc b start-row) 56 | (send dc set-text-mode 'solid) 57 | (send dc set-text-background "black") 58 | (send dc set-text-foreground "white") 59 | (define-values (font-width font-height _ __) (send dc get-text-extent "M")) 60 | (let ([p (Buffer-cur b)]) 61 | (define-values (start end) (apply values (get-scope b))) 62 | (define-values (r1 c1) (Point-row-col start)) 63 | (define line-height (line-size)) 64 | (define x (* c1 font-width)) 65 | (define y (* (- r1 start-row) line-height)) 66 | (define-values (r2 c2) (Point-row-col end)) 67 | (cond 68 | [(equal? r2 r1) 69 | (define str (Buffer-substring-at b r2 c1 (+ c2 1))) 70 | (send dc draw-text str x y)] 71 | [else 72 | (define lines (Buffer-lines b)) 73 | (define l1 (list-ref lines (Point-row start))) 74 | (define l2 (list-ref lines (Point-row end))) 75 | (define str1 (Buffer-substring-at b r1 c1 (string-length l1))) 76 | (define str2 (Buffer-substring-at b r2 0 (+ c2 1))) 77 | (send dc draw-text str1 x y) 78 | (define x2 0) 79 | (define y2 (* (- r2 start-row) line-height)) 80 | (send dc draw-text str2 x2 y2) 81 | (for ([ri (in-range (+ r1 1) r2)]) 82 | (define xi 0) 83 | (define yi (* (- ri start-row) line-height)) 84 | (define stri (list-ref lines ri)) 85 | (send dc draw-text stri xi yi))]) 86 | )))) 87 | 88 | (define visual-line-mode-base% 89 | (class mode% 90 | (super-new) 91 | (abstract get-scope) 92 | (define/override (draw-points dc b start-row) 93 | (send dc set-text-mode 'solid) 94 | (send dc set-text-background "black") 95 | (send dc set-text-foreground "white") 96 | (define-values (font-width font-height _ __) (send dc get-text-extent "M")) 97 | (let ([p (Buffer-cur b)]) 98 | (define-values (start end) (apply values (get-scope b))) 99 | (define-values (r1 _) (Point-row-col start)) 100 | (define line-height (line-size)) 101 | (define x 0) 102 | (define y (* (- r1 start-row) line-height)) 103 | (define-values (r2 __) (Point-row-col end)) 104 | (define lines (Buffer-lines b)) 105 | (for ([ri (in-range r1 (+ r2 1))]) 106 | (define xi 0) 107 | (define yi (* (- ri start-row) line-height)) 108 | (define stri (list-ref lines ri)) 109 | (send dc draw-text stri xi yi)) 110 | )))) 111 | 112 | (define visual-block-mode-base% 113 | (class mode% 114 | (super-new) 115 | (abstract get-scope) 116 | (define/override (draw-points dc b start-row) 117 | (send dc set-text-mode 'solid) 118 | (send dc set-text-background "black") 119 | (send dc set-text-foreground "white") 120 | (define-values (font-width font-height _ __) (send dc get-text-extent "M")) 121 | (let ([p (Buffer-cur b)]) 122 | (define-values (start end) (apply values (get-scope b))) 123 | (define-values (r1 c1) (Point-row-col start)) 124 | (define line-height (line-size)) 125 | (define-values (r2 c2) (Point-row-col end)) 126 | (define lines (Buffer-lines b)) 127 | (define c-min (min c1 c2)) 128 | (define c-max (max c1 c2)) 129 | (define x (* c-min font-width)) 130 | (for ([ri (in-range r1 (+ r2 1))]) 131 | (define yi (* (- ri start-row) line-height)) 132 | (define line (list-ref lines ri)) 133 | (when (>= (string-length line) c-min) 134 | (define end-c (min (add1 c-max) (string-length line))) 135 | (define stri (substring line c-min end-c)) 136 | (send dc draw-text stri x yi))) 137 | )))) 138 | -------------------------------------------------------------------------------- /gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/gui "core.rkt" "controller.rkt" "key-event-key.rkt") 4 | 5 | (define (new-editor-frame controller) 6 | (define min-width 800) 7 | (define min-height 800) 8 | (define text-color (make-object color% "black")) 9 | (define font-size 16) 10 | (define font-family 'modern) ; fixed width 11 | (define fixed-font (make-object font% font-size font-family)) 12 | (define frame (new frame% [label "Editor"])) 13 | (define subeditor-canvas% 14 | (class canvas% 15 | (define/override (on-char event) 16 | (cond 17 | [(ignored-key-event? event) (void)] 18 | [else 19 | (define key-symbol (key-event->key-symbol event)) 20 | (displayln (~e key-symbol)) 21 | (send controller on-char key-symbol) 22 | (define b (send controller get-buffer)) 23 | (send status-line set-label (string-append (~v (Buffer-cur b)) " " (send controller get-status-line))) 24 | (send canvas on-paint)])) 25 | (define/override (on-paint) 26 | (define b (send controller get-buffer)) 27 | (render-buffer b canvas 16 controller)) 28 | (define start-row 0) 29 | (define end-row #f) 30 | (define (render-buffer b canvas font-size controller) 31 | (define dc (send canvas get-dc)) 32 | (send dc clear) 33 | (send dc suspend-flush) 34 | (send dc set-text-foreground text-color) 35 | (send dc set-text-background "white") 36 | (send dc set-font fixed-font) 37 | ;; Dimensions 38 | (define-values (width height) (send canvas get-client-size)) 39 | (define fs font-size) 40 | (define ls (+ fs 1)) ; linesize -- 1 pixel for spacing 41 | ;; Placement of point relative to lines on screen 42 | (define num-lines-on-screen (max 0 (quotient height ls))) 43 | (define-values (row col) (Point-row-col (Buffer-cur b))) 44 | ;(displayln (list 'before: 'row row 'start-row start-row 'end-row end-row 'n num-lines-on-screen)) 45 | (define n num-lines-on-screen) 46 | (when (not end-row) 47 | (set! end-row (+ start-row n -1))) 48 | (when (<= (length (Buffer-lines b)) num-lines-on-screen) 49 | (set! start-row 0) 50 | (set! end-row (sub1 (length (Buffer-lines b))))) 51 | 52 | (when (< row start-row) 53 | (define new-start-row row) 54 | (define new-end-row (+ new-start-row n -1)) 55 | (set! start-row new-start-row) 56 | (set! end-row new-end-row) 57 | ;(displayln (list 'new-start-and-end start-row end-row)) 58 | ) 59 | 60 | (when (> row end-row) 61 | (define new-end-row row) 62 | (define new-start-row (- new-end-row n -1)) 63 | (set! start-row new-start-row) 64 | (set! end-row new-end-row) 65 | ;(displayln (list 'new-start-and-end start-row end-row)) 66 | ) 67 | 68 | ; draw-string : string real real -> real 69 | ; draw string t at (x,y), return point to draw next string 70 | (define (draw-string t x y) 71 | (send dc draw-text t x y) 72 | (+ y ls)) 73 | ; draw text 74 | (define after-end-row (add1 end-row)) 75 | (define window-lines 76 | (drop (take (Buffer-lines b) after-end-row) start-row)) 77 | ;(displayln (~e 'window-lines window-lines)) 78 | (define ymin 0 #;(send canvas get-y)) 79 | (define xmin 0 #;(send canvas get-x)) 80 | (for/fold ([y ymin]) 81 | ([l window-lines]) 82 | (draw-string l xmin y)) 83 | ;(displayln (~v 'start-row start-row 'end-row end-row)) 84 | (send controller draw-points dc start-row) 85 | ; resume flush 86 | (send dc resume-flush)) 87 | (super-new))) 88 | (define canvas (new subeditor-canvas% [parent frame])) 89 | (send canvas min-client-width 400) 90 | (send canvas min-client-height 100) 91 | (define status-line (new message% [parent frame] [label "No news"])) 92 | (send status-line min-width min-width) 93 | (send frame show #t)) 94 | 95 | (module+ test 96 | (require (submod "core.rkt" test)) 97 | (define b (new-Buffer #;'("Sing, O goddess, the anger" 98 | "of Achilles son" 99 | "of Peleus, that brought" 100 | ", the anger" 101 | "of Achilles son" 102 | "x") 103 | '("Sing, O goddess, the anger" 104 | "of Achilles son" 105 | "of Peleus, that brought"))) 106 | (define controller (new controller% [buffer b])) 107 | (new-editor-frame controller) 108 | ) 109 | -------------------------------------------------------------------------------- /illead.txt: -------------------------------------------------------------------------------- 1 | Sing, O goddess, the anger of Achilles son of Peleus, that brought 2 | countless ills upon the Achaeans. Many a brave soul did it send hurrying 3 | down to Hades, and many a hero did it yield a prey to dogs and vultures, 4 | for so were the counsels of Jove fulfilled from the day on which the 5 | son of Atreus, king of men, and great Achilles, first fell out with 6 | one another. 7 | -------------------------------------------------------------------------------- /insert-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require "core.rkt" "wrapped-move-scope.rkt" "scope.rkt" "diff.rkt" "params.rkt" "change.rkt") 6 | 7 | (module+ test (require rackunit)) 8 | 9 | (define (from-mode diffs) 10 | ;(displayln (~e 'from-mode diffs)) 11 | (cond 12 | [(empty? diffs) 'char] 13 | [else 14 | (define scope (Region-scope (Diff-item-old-region (last diffs)))) 15 | (Scope-mode scope)])) 16 | 17 | (define (insert-escape! b leftest-point start-point org-lines start-motions-lst change-motions diff-lst diff-manager reg-manager count) 18 | (define mode (from-mode diff-lst)) 19 | (define p (Buffer-cur b)) 20 | (define lines (Buffer-lines b)) 21 | (define real-count (or count 1)) 22 | (define-values (new-p new-lines new-diffs) 23 | (cond 24 | [(equal? mode 'char) 25 | (insert-escape-char-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst real-count)] 26 | [(equal? mode 'line) 27 | (insert-escape-line-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst real-count)] 28 | [(equal? mode 'block) 29 | (insert-escape-block-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst real-count)])) 30 | (set-Buffer-cur! b new-p) 31 | (set-Buffer-lines! b new-lines) 32 | (send diff-manager push-diffs! new-diffs) 33 | (define inserted-lines (Region-lines (Diff-item-new-region (first new-diffs)))) 34 | (send reg-manager set-last-cmd (make-Command 'change change-motions #:op-params inserted-lines #:start-motions-lst start-motions-lst))) 35 | 36 | (define (insert-escape-line-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst count) 37 | (insert-escape-char-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst count)) 38 | 39 | (define (repeat-lines-char-mode lines count) 40 | (for/fold ([new-lines '()]) 41 | ([i count]) 42 | (define-values (_ n-lines) (insert-lines-at (Point 0 0 0) new-lines lines 'char)) 43 | n-lines)) 44 | 45 | (define (insert-escape-char-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst count) 46 | (define new-scope (Scope leftest-point p #t #f 'char)) 47 | (define inserted-lines (Scoped-lines new-scope lines)) 48 | (define repeated-inserted-lines (repeat-lines-char-mode inserted-lines count)) 49 | (define repeated-new-point (after-lines-point p repeated-inserted-lines 'char)) 50 | (define repeated-new-scope (Scope leftest-point repeated-new-point #t #f 'char)) 51 | (define new-region (Region repeated-new-scope repeated-inserted-lines)) 52 | (define old-scope (Scope leftest-point start-point #t #f 'char)) 53 | (define deleted-lines (Scoped-lines old-scope org-lines)) 54 | (define old-region (Region old-scope deleted-lines)) 55 | (define new-diff (Diff-item old-region new-region)) 56 | (define-values (new-p new-lines) (redo new-diff org-lines)) 57 | (define diffs (cons new-diff diff-lst)) 58 | (values new-p new-lines diffs)) 59 | 60 | (define (sublist list start [end #f]) 61 | (define sublist1 (if end (take list end) list)) 62 | (drop sublist1 start)) 63 | 64 | (define (insert-escape-block-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst count) 65 | ;(displayln (~e 'insert-escape-block-mode p lines leftest-point start-point org-lines start-motions-lst change-motions diff-lst)) 66 | (define deleted-scope (Region-scope (Diff-item-old-region (last diff-lst)))) 67 | (match-define (Scope start end _ _ _) deleted-scope) 68 | (unless (equal? start start-point) (error (~e 'unmatched-scope start "!=" start-point))) 69 | (define row-min (min (Point-row start) (Point-row end))) 70 | (define row-max (max (Point-row start) (Point-row end))) 71 | (define leftest-col (Point-col leftest-point)) 72 | (define start-col (Point-col start-point)) 73 | (define cur-col (Point-col p)) 74 | (define inserted-line (substring (list-ref lines row-min) leftest-col cur-col)) 75 | (define repeated-inserted-line 76 | (for/fold ([line ""]) 77 | ([i count]) 78 | (string-append line inserted-line))) 79 | (define inserted-lines 80 | (for/list 81 | ([l (sublist lines row-min (add1 row-max))]) 82 | (cond 83 | [(> start-col (string-length l)) 84 | ""] 85 | [else repeated-inserted-line]))) 86 | (define new-col (+ start-col (string-length repeated-inserted-line))) 87 | (define new-scope (Scope leftest-point (Point row-max new-col new-col) #t #f 'block)) 88 | (define new-region (Region new-scope inserted-lines)) 89 | (define old-scope (Scope leftest-point (struct-copy Point start-point [row row-max]) #t #f 'block)) 90 | (define deleted-line (substring (list-ref org-lines row-min) leftest-col start-col)) 91 | (define row-num (- row-max row-min -1)) 92 | (define deleted-lines (make-list row-num deleted-line)) 93 | (define old-region (Region old-scope deleted-lines)) 94 | (define new-diff (Diff-item old-region new-region)) 95 | (define-values (new-p new-lines) (redo new-diff org-lines)) 96 | (define diffs (cons new-diff diff-lst)) 97 | (values p new-lines diffs)) ; be consistent with char/line modes. 98 | 99 | (module+ test 100 | (let-values ([(new-p new-lines new-diffs) 101 | (insert-escape-block-mode (Point 0 3 3) 102 | '("xyz of Atreus" " another.") 103 | (Point 0 0 0) 104 | (Point 0 0 0) 105 | '(" of Atreus" " another.") 106 | '() 107 | (Visual-Motion 1 3 'block) 108 | (list (Diff-item 109 | (Region (Scope (Point 0 0 0) (Point 1 3 3) #t #f 'block) '("son" "one")) 110 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'block) '()))) 111 | 1)]) 112 | (check-equal? new-p (Point 0 3 3)) 113 | (check-equal? new-lines '("xyz of Atreus" "xyz another.")) 114 | (check-equal? new-diffs 115 | (list 116 | (Diff-item 117 | (Region (Scope (Point 0 0 0) (Point 1 0 0) #t #f 'block) '("" "")) 118 | (Region (Scope (Point 0 0 0) (Point 1 3 3) #t #f 'block) '("xyz" "xyz"))) 119 | (Diff-item 120 | (Region (Scope (Point 0 0 0) (Point 1 3 3) #t #f 'block) '("son" "one")) 121 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'block) '())))) 122 | )) 123 | 124 | 125 | (define (insert-key-to-scope-motion k) 126 | (match k 127 | ['C '$] 128 | ['s 'right*] 129 | ['S '$*] 130 | ['i 'nope] 131 | ['a 'nope] 132 | ['I 'nope] 133 | ['A 'nope] 134 | ['o 'nope] 135 | ['O 'nope] 136 | [_ (error (~e 'missing-case-in-insert-key-to-scope-motion k))])) 137 | 138 | (define (insert-key-to-start-motion-lst k) 139 | (match k 140 | ['C (list 'nope)] 141 | ['s (list 'nope)] 142 | ['S (list '|0|)] 143 | ['i (list 'nope)] 144 | ['a (list 'right*)] 145 | ['I (list '^)] 146 | ['A (list '$*)] 147 | ['o (list '$*)] 148 | ['O (list 'up '$*)] 149 | [_ (error (~e 'missing-case-in-insert-key-to-start-motion-lst k))])) 150 | -------------------------------------------------------------------------------- /key-event-key.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/gui/base) 4 | 5 | (provide key-event->key-symbol ignored-key-event?) 6 | 7 | (define (ignored-key-event? event) 8 | (define k (send event get-key-code)) 9 | (match k 10 | [(or 'release 'control 'shift 'rcontrol 'rshift) 11 | #t] 12 | [_ #f])) 13 | 14 | (define (key-event->key-symbol event) 15 | (define k (send event get-key-code)) 16 | (define base-key 17 | (match k 18 | [#\return "CR"] 19 | [#\backspace "BACKSPACE"] 20 | [(? char? k) (string k)] 21 | ['escape "Esc"] 22 | ['left "Left"] 23 | ['right "Right"] 24 | ['up "Up"] 25 | ['down "Down"] 26 | [_ (error 'missing (~v k))])) 27 | (define complex-key 28 | (for/fold ([com-key base-key]) 29 | ([func-S (list (cons (send event get-meta-down) "M") 30 | ;(cons (send event get-shift-down) "S") 31 | (cons (send event get-control-down) "C") 32 | (cons (send event get-alt-down) "A"))]) 33 | (cond 34 | [(car func-S) (string-append (cdr func-S) "-" com-key)] 35 | [else com-key]))) 36 | (define final-string 37 | (cond 38 | [(> (string-length complex-key) 1) (string-append "<" complex-key ">")] 39 | [else complex-key])) 40 | (string->symbol final-string)) -------------------------------------------------------------------------------- /macro-recorder.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide macro-recorder%) 4 | 5 | (define macro-recorder% 6 | (class object% 7 | (super-new) 8 | [init-field controller] 9 | (define macro-reg #f) 10 | (define macro-content '()) 11 | (define last-execute-reg #f) 12 | (define/public (start-record-macro-to-reg! reg) 13 | (set! last-execute-reg #f) 14 | (set! macro-reg reg)) 15 | (define/public (stop-record-macro-to-reg! reg-manager) 16 | (define fixed-content (reverse (drop macro-content 1))) 17 | (send reg-manager set-named-reg! macro-reg fixed-content) 18 | (set! macro-reg #f) 19 | (set! macro-content '())) 20 | (define/public (recording?) 21 | macro-reg) 22 | (define/public (execute-macro-from-reg macro-reg reg-manager diff-manager count) 23 | (cond 24 | [(equal? macro-reg #\@) 25 | (unless last-execute-reg (error 'no-previously-used-register))] 26 | [else 27 | (set! last-execute-reg macro-reg)]) 28 | (define content (send reg-manager get-named-reg last-execute-reg)) 29 | (define org-diff-len (send diff-manager diff-stack-len-index)) 30 | (for ([i (or count 1)]) 31 | (for ([k content]) 32 | (send controller on-char k))) 33 | (send diff-manager combine-since! org-diff-len)) 34 | (define/public (record! key-symbol) 35 | (when macro-reg (set! macro-content (cons key-symbol macro-content)))) 36 | )) -------------------------------------------------------------------------------- /match-paren.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide %-point a-paren-pair) 4 | 5 | (require "core.rkt" "common-utils.rkt" "Scope.rkt") 6 | 7 | (module+ test (require rackunit)) 8 | 9 | (define (get-paren-pair char) 10 | (match char 11 | [(or #\( #\)) (cons #\( #\))] 12 | [(or #\{ #\}) (cons #\{ #\})] 13 | [(or #\[ #\]) (cons #\[ #\])] 14 | [_ (error 'missing-case (~v char))])) 15 | 16 | (define (line-match-forwards paren-pair line counter) 17 | (for/fold ([l-counter counter] 18 | [col- 0]) 19 | ([col (in-naturals)] 20 | [c line] 21 | #:when (or (equal? c (car paren-pair)) (equal? c (cdr paren-pair))) 22 | #:break (= l-counter 0)) ; todo start from p 23 | (define local-counter 24 | (cond 25 | [(equal? c (car paren-pair)) 26 | (add1 l-counter)] 27 | [else (sub1 l-counter)])) 28 | (values local-counter col))) 29 | 30 | (define (string-reverse x) 31 | (list->string (reverse (string->list x)))) 32 | 33 | (define (line-match-backwards paren-pair line counter) 34 | (for/fold ([l-counter counter] 35 | [col- (sub1 (string-length line))]) 36 | ([col (in-range (sub1 (string-length line)) -1 -1)] 37 | [c (string-reverse line)] 38 | #:when (or (equal? c (car paren-pair)) (equal? c (cdr paren-pair))) 39 | #:break (= l-counter 0)) ; todo start from p 40 | (define local-counter 41 | (cond 42 | [(equal? c (car paren-pair)) 43 | (add1 l-counter)] 44 | [else (sub1 l-counter)])) 45 | (values local-counter col))) 46 | 47 | (define (%-right-point p lines [count 1] [check? #t] [paren-lst #f]) 48 | (define-values (p-row p-col) (Point-row-col p)) 49 | (define-values (_ this after) (before-this-after lines p-row)) 50 | (define current-char (string-ref this p-col)) 51 | (define paren-pair (or paren-lst (get-paren-pair current-char))) 52 | (unless (or (not check?) (equal? current-char (car paren-pair))) (error 'incorrect-paren (~v current-char))) 53 | (define-values (init-counter init-col) (line-match-forwards paren-pair (substring this (add1 p-col)) count)) 54 | (define init-col+ (+ init-col p-col 1)) 55 | (define-values (c pp) 56 | (for/fold ([counter init-counter] 57 | [point (Point p-row init-col+ init-col+)]) 58 | ([row (in-naturals (add1 p-row))] 59 | [line after] 60 | #:break (= counter 0)) 61 | (define-values (l-counter l-col) (line-match-forwards paren-pair line counter)) 62 | (values l-counter (Point row l-col l-col)) 63 | )) 64 | (unless (equal? c 0) (error 'no-matched-parens (~v c))) 65 | pp) 66 | 67 | (module+ test 68 | (check-equal? (%-right-point (Point 0 1 1) '("((-[)])")) (Point 0 4 4)) 69 | (check-equal? (%-right-point (Point 0 3 3) '("((-[" 70 | ")])")) (Point 1 1 1)) 71 | (check-equal? (%-right-point (Point 0 0 0) '("(123" "3))")) (Point 1 1 1)) 72 | ) 73 | 74 | (define (%-left-point p lines [count 1] [check? #t] [paren-lst #f]) 75 | (define-values (p-row p-col) (Point-row-col p)) 76 | (define-values (before this _) (before-this-after lines p-row)) 77 | (define current-char (string-ref this p-col)) 78 | (define paren-pair (or paren-lst (get-paren-pair current-char))) 79 | (unless (or (not check?) (equal? current-char (cdr paren-pair))) (error 'incorrect-paren (~v current-char))) 80 | (define-values (init-counter init-col) (line-match-backwards paren-pair (substring this 0 p-col) (- count))) 81 | (define-values (c pp) 82 | (for/fold ([counter init-counter] 83 | [point (Point p-row init-col init-col)]) 84 | ([row (in-range (sub1 p-row) -1 -1)] 85 | [line (reverse before)] 86 | #:break (= counter 0)) 87 | (define-values (l-counter l-col) (line-match-backwards paren-pair line counter)) 88 | (values l-counter (Point row l-col l-col)) 89 | )) 90 | (unless (equal? c 0) (error 'no-matched-parens (~v c))) 91 | pp) 92 | 93 | (module+ test 94 | (check-equal? (%-left-point (Point 0 4 4) '("((-[)])")) (Point 0 1 1)) 95 | (check-equal? (%-left-point (Point 1 1 1) '("((-[" 96 | ")])")) (Point 0 3 3)) 97 | (check-equal? (%-left-point (Point 1 1 1) '("(123" "3))")) (Point 0 0 0)) 98 | ) 99 | 100 | (define (is-left-paren? char [paren-pair #f]) 101 | (equal? char (car (or paren-pair (get-paren-pair char))))) 102 | 103 | (define (is-right-paren? char [paren-pair #f]) 104 | (equal? char (cdr (or paren-pair (get-paren-pair char))))) 105 | 106 | (define (%-point p lines) 107 | (define-values (p-row p-col) (Point-row-col p)) 108 | (define-values (before this after) (before-this-after lines p-row)) 109 | (define char (string-ref this p-col)) 110 | (cond 111 | [(is-left-paren? char) 112 | (%-right-point p lines)] 113 | [(is-right-paren? char) 114 | (%-left-point p lines)] 115 | [else (error 'not-on-a-paren)])) 116 | 117 | (module+ test 118 | (let ([lines '("((-" 119 | "[)])")]) 120 | (check-equal? (%-point (%-point (Point 0 1 1) lines) lines) (Point 0 1 1)))) 121 | 122 | (define (a-paren-pair paren-pair p lines count) ;todo fix count 123 | (define-values (p-row p-col) (Point-row-col p)) 124 | (define this (list-ref lines p-row)) 125 | (define char (string-ref this p-col)) 126 | (define left-p 127 | (cond 128 | [(is-left-paren? char paren-pair) p] 129 | [else (%-left-point p lines count #f paren-pair)])) 130 | (define right-p 131 | (cond 132 | [(is-right-paren? char paren-pair) p] 133 | [else (%-right-point p lines count #f paren-pair)])) 134 | (cons left-p right-p)) 135 | 136 | (module+ test 137 | (let ([lines '("((-" 138 | "[)])")]) 139 | (check-equal? (a-paren-pair '(#\( . #\)) (Point 0 1 1) lines 1) 140 | (cons (Point 0 1 1) (Point 1 1 1))) 141 | (check-equal? (a-paren-pair '(#\[ . #\]) (Point 1 1 1) lines 1) 142 | (cons (Point 1 0 0) (Point 1 2 2))) 143 | ) 144 | ) -------------------------------------------------------------------------------- /mode-base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | 4 | (define mode% 5 | (class object% 6 | (super-new) 7 | (abstract on-char draw-points) 8 | (define/public (get-status-line) 9 | ""))) 10 | -------------------------------------------------------------------------------- /mode-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require "core.rkt" "wrapped-move-scope.rkt" "scope.rkt" "change.rkt" "operators.rkt" "params.rkt") 6 | 7 | (define (repeat c p lines reg-manager #:count [count 1]) 8 | (match-define (Command op start-motions-lst scope-motions inserted-lines) c) 9 | (define new-p 10 | (for/fold ([new-p p]) 11 | ([motion start-motions-lst]) 12 | (move-point motion new-p lines))) 13 | (execute op scope-motions new-p lines reg-manager #:count count #:op-params inserted-lines)) 14 | 15 | (define (execute op motions p lines reg-manager #:count [count 1] #:op-params [op-params '()]) 16 | (cond 17 | [motions 18 | (match op 19 | [(or (== delete-op) (== yank-op) (== pre-paste-op) (== post-paste-op)) 20 | (for/fold 21 | ([pp p] 22 | [ls lines] 23 | [diffs '()]) 24 | ([i count]) 25 | (define scope (get-point-scope motions pp ls)) 26 | (define-values (new-point new-lines new-diffs) (op scope p lines reg-manager)) 27 | (values new-point new-lines (append new-diffs diffs)))] 28 | [(? procedure?) 29 | (for/fold 30 | ([pp p] 31 | [ls lines] 32 | [diffs '()]) 33 | ([i count]) 34 | (define scope (get-point-scope motions pp ls)) 35 | (define-values (new-point new-lines new-diffs) (op scope p lines)) 36 | (values new-point new-lines (append new-diffs diffs)))] 37 | ['change 38 | (define inserted-lines op-params) 39 | (define scope (get-point-scope motions p lines)) 40 | ;(displayln (~e 'change scope rel-motion 'p p)) 41 | (replace scope p lines inserted-lines (Scope-mode scope))] 42 | ['replace-op 43 | (define char op-params) 44 | (define scope (get-point-scope motions p lines)) 45 | ;(displayln (~e 'replace-op 'scope scope)) 46 | (replace-op scope p lines char)] 47 | [_ (error 'missing-execute-case (~a op))])] 48 | [else (values p lines '())] 49 | )) 50 | 51 | (define (update-Buffer-and-diffs! b diff-manager) 52 | (lambda (new-p new-ls [new-diffs '()]) 53 | (set-Buffer-cur! b new-p) 54 | (set-Buffer-lines! b new-ls) 55 | (send diff-manager push-diffs! new-diffs))) 56 | 57 | (define (Buffer-delete-char! b *-mode?) 58 | (define p (Buffer-cur b)) 59 | (define-values (new-point new-lines) (lines-delete-char-after-point p (Buffer-lines b) *-mode?)) 60 | (set-Buffer-cur! b new-point) 61 | (set-Buffer-lines! b new-lines)) 62 | 63 | (define (update-count k count) 64 | (define digit (- (char->integer k) (char->integer #\0))) 65 | (cond 66 | [count 67 | (+ (* 10 count) digit)] 68 | [else digit])) 69 | 70 | (define (scope-to-motion scope) 71 | (match-define (Scope start end dir include-real-end? mode) scope) 72 | (define rel-row (- (Point-row end) (Point-row start))) 73 | (define include-end (and dir include-real-end?)) 74 | (define additional-count (if include-end 1 0)) 75 | (cond 76 | [(equal? mode 'block) 77 | (define rel-col (+ (abs (- (Point-col end) (Point-col start))) additional-count)) 78 | (Visual-Motion rel-row rel-col 'block)] 79 | [(equal? mode 'char) 80 | (cond 81 | [(equal? rel-row 0) 82 | (define count (- (Point-col end) (Point-col start))) 83 | (make-Motion 'right #:count (+ count additional-count))] 84 | [else 85 | (Visual-Motion rel-row (+ (Point-col end) additional-count) 'char)])] 86 | [(equal? mode 'line) 87 | (make-Motion 'down-line-mode #:count rel-row)] 88 | [else (error (~e 'not-implemented-in-scope-to-motion scope))])) 89 | 90 | (define (move! motions p b) 91 | ;(displayln (list 'motions motions)) 92 | (define lines (Buffer-lines b)) 93 | (define new-point (move-point motions p lines)) 94 | (set-Buffer-cur! b new-point)) 95 | -------------------------------------------------------------------------------- /operators.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require "core.rkt" "wrapped-move-scope.rkt" "change.rkt" "params.rkt" "diff-utils.rkt" "reg-manager.rkt") 6 | 7 | (module+ test (require rackunit)) 8 | 9 | (define (delete-op scope p lines reg-manager) 10 | (define-values (new-point new-lines) (delete-scope scope lines)) 11 | (define deleted-lines (Scoped-lines scope lines)) 12 | (send reg-manager set-yank-reg (make-Reg deleted-lines (Scope-mode scope))) 13 | (define diffs (get-delete-diffs scope lines)) 14 | (values new-point new-lines diffs)) 15 | 16 | (module+ test 17 | (let-values ([(p lines diffs) 18 | (delete-op (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'line) 19 | (Point 0 0 0) '("one another.") (new reg-manager%))]) 20 | (check-equal? p (Point 0 0 0)) 21 | (check-equal? lines '("")) 22 | (check-equal? diffs (list (Diff-item 23 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'line) '("one another.")) 24 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'line) '()))))) 25 | (let-values ([(p lines diffs) 26 | (delete-op (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'char) 27 | (Point 0 0 0) '("one another.") (new reg-manager%))]) 28 | (check-equal? p (Point 0 0 0)) 29 | (check-equal? lines '("ne another.")) 30 | (check-equal? diffs (list (Diff-item 31 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'char) '("o")) 32 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()))))) 33 | (let-values ([(p lines diffs) 34 | (delete-op (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'block) 35 | (Point 0 0 0) '("one another.") (new reg-manager%))]) 36 | (check-equal? p (Point 0 0 0)) 37 | (check-equal? lines '("ne another.")) 38 | (check-equal? diffs (list (Diff-item 39 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'block) '("o")) 40 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'block) '())))))) 41 | 42 | (define (yank-op scope p lines reg-manager) 43 | (define-values (new-point new-lines) (delete-scope scope lines)) 44 | (define yanked-lines (Scoped-lines scope lines)) 45 | (send reg-manager set-yank-reg (make-Reg yanked-lines (Scope-mode scope))) 46 | (values p lines '())) 47 | 48 | (module+ test 49 | (let ([reg-manager (new reg-manager%)]) 50 | (define-values (_ __ ___) 51 | (yank-op (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'line) 52 | (Point 0 0 0) '("one another.") reg-manager)) 53 | (check-equal? (send reg-manager get-yank-reg) (Reg '("one another.") 'line)))) 54 | 55 | (define (replace scope p lines inserted-lines mode) 56 | (define updated-scope (struct-copy Scope scope [mode mode])) 57 | (define start (Scope-start updated-scope)) 58 | (define-values (new-point new-lines) 59 | (replace-scope updated-scope lines inserted-lines)) 60 | (define replace-diffs 61 | (get-replace-diffs updated-scope start inserted-lines mode lines)) 62 | (values new-point new-lines replace-diffs)) 63 | 64 | (module+ test 65 | (let-values ([(p lines diffs) 66 | (replace (Scope (Point 0 0 0) (Point 0 1 1) #t #f 'line) 67 | (Point 0 4 4) '("one another.") 68 | '("x.") 69 | 'line)]) 70 | (check-equal? p (Point 0 0 0)) 71 | (check-equal? lines '("x." "one another.")) 72 | (check-equal? diffs (list 73 | (Diff-item 74 | (Region (Scope (Point 0 0 0) (Point 0 1 1) #t #f 'line) '()) 75 | (Region (Scope (Point 0 0 0) (Point 1 0 0) #t #f 'line) '("x.")))))) 76 | (let-values ([(p lines diffs) 77 | (replace (Scope (Point 0 0 0) (Point 0 1 1) #t #f 'char) 78 | (Point 0 4 4) '("one another.") 79 | '("x.") 80 | 'char)]) 81 | (check-equal? p (Point 0 2 2)) 82 | (check-equal? lines '("x.ne another.")) 83 | (check-equal? diffs (list 84 | (Diff-item 85 | (Region (Scope (Point 0 0 0) (Point 0 1 1) #t #f 'char) '("o")) 86 | (Region (Scope (Point 0 0 0) (Point 0 2 2) #t #f 'char) '("x.")))))) 87 | (let-values ([(p lines diffs) 88 | (replace (Scope (Point 0 0 0) (Point 1 1 1) #t #f 'block) 89 | (Point 0 4 4) '("one" "another.") 90 | '("x." "y.") 91 | 'block)]) 92 | (check-equal? p (Point 0 0 0)) 93 | (check-equal? lines '("x.ne" "y.nother.")) 94 | (check-equal? diffs 95 | (list 96 | (Diff-item 97 | (Region (Scope (Point 0 0 0) (Point 1 1 1) #t #f 'block) '("o" "a")) 98 | (Region (Scope (Point 0 0 0) (Point 1 2 2) #t #f 'block) '("x." "y."))))))) 99 | 100 | (define (pre-paste-op scope p lines reg-manager) 101 | (define reg (send reg-manager get-yank-reg)) 102 | (define inserted-lines (Reg-lines reg)) 103 | (define mode (Reg-mode reg)) 104 | (define deleted-lines (Scoped-lines scope lines)) 105 | (when (not (empty-lines? deleted-lines)) 106 | (send reg-manager set-yank-reg (make-Reg deleted-lines mode))) 107 | (replace scope p lines inserted-lines mode)) 108 | 109 | (module+ test 110 | (let ([reg-manager (new reg-manager%)]) 111 | (let-values ([(p lines diffs) 112 | (pre-paste-op (Scope (Point 0 0 0) (Point 1 1 1) #t #t 'block) 113 | (Point 0 4 4) '("two" "another.") reg-manager)]) 114 | (check-equal? p (Point 0 0 0)) 115 | (check-equal? lines '("other.")) 116 | (check-equal? diffs 117 | (list 118 | (Diff-item 119 | (Region (Scope (Point 0 0 0) (Point 1 1 1) #t #t 'char) '("two" "an")) 120 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()))))))) 121 | 122 | (define (post-paste-op scope p lines reg-manager) 123 | (define mode (Reg-mode (send reg-manager get-yank-reg))) 124 | (define start (Scope-start scope)) 125 | (define updated-scope 126 | (cond 127 | [(not (empty-scope? scope)) scope] 128 | [else 129 | (define updated-start 130 | (cond 131 | [(equal? mode 'line) (Point (add1 (Point-row start)) 0 0)] 132 | [else (move-point (make-Motion 'right*) start lines)])) 133 | (struct-copy Scope scope [start updated-start] [end updated-start] [mode mode])])) 134 | (pre-paste-op updated-scope p lines reg-manager)) 135 | 136 | (module+ test 137 | (let ([reg-manager (new reg-manager%)]) 138 | (let-values ([(p lines diffs) 139 | (post-paste-op (Scope (Point 0 0 0) (Point 1 1 1) #t #t 'block) 140 | (Point 0 4 4) '("two" "another.") reg-manager)]) 141 | (check-equal? p (Point 0 0 0)) 142 | (check-equal? lines '("other.")) 143 | (check-equal? diffs 144 | (list 145 | (Diff-item 146 | (Region (Scope (Point 0 0 0) (Point 1 1 1) #t #t 'char) '("two" "an")) 147 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()))))))) 148 | 149 | (define (right-shift-op scope p lines) 150 | (define diffs (get-right-shift-diffs scope lines)) 151 | (define-values (new-point new-lines) (right-shift-scope scope lines)) 152 | (values new-point new-lines diffs)) 153 | 154 | (define (left-shift-op scope p lines) 155 | (define diffs (get-left-shift-diffs scope lines)) 156 | (define-values (new-point new-lines) (left-shift-scope scope lines)) 157 | (values new-point new-lines diffs)) 158 | 159 | (module+ test 160 | (let-values ([(p lines diffs) 161 | (right-shift-op (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'block) 162 | (Point 0 4 4) '("two" "another."))]) 163 | (check-equal? p (Point 0 4 4)) 164 | (check-equal? lines '(" two" "another.")) 165 | (check-equal? diffs 166 | (list 167 | (Diff-item 168 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '()) 169 | (Region (Scope (Point 0 0 0) (Point 0 4 4) #t #f 'char) '(" ")))))) 170 | (let-values ([(p lines diffs) 171 | (left-shift-op (Scope (Point 0 0 0) (Point 1 0 0) #t #f 'block) 172 | (Point 0 4 4) '(" two" " another."))]) 173 | (check-equal? p (Point 0 0 0)) 174 | (check-equal? lines '("two" " another.")) 175 | (check-equal? diffs 176 | (list 177 | (Diff-item 178 | (Region (Scope (Point 0 0 0) (Point 0 2 2) #t #f 'char) '(" ")) 179 | (Region (Scope (Point 0 0 0) (Point 0 0 0) #t #f 'char) '())) 180 | (Diff-item 181 | (Region (Scope (Point 1 0 0) (Point 1 4 4) #t #f 'char) '(" ")) 182 | (Region (Scope (Point 1 2 2) (Point 1 2 2) #t #f 'char) '())))))) 183 | 184 | (define (g-proc scope p lines proc) 185 | (define scoped (Scoped-lines scope lines)) 186 | (define replaced-lines (map proc scoped)) 187 | (replace scope p lines replaced-lines (Scope-mode scope))) 188 | 189 | (define (char-swapcase char) 190 | (if 191 | (char-upper-case? char) 192 | (char-downcase char) 193 | (char-upcase char))) 194 | 195 | (define (string-swapcase str) 196 | (list->string 197 | (map char-swapcase (string->list str)))) 198 | 199 | (define (g~-op scope p lines) 200 | (g-proc scope p lines string-swapcase)) 201 | 202 | (define (gu-op scope p lines) 203 | (g-proc scope p lines string-downcase)) 204 | 205 | (define (gU-op scope p lines) 206 | (g-proc scope p lines string-upcase)) 207 | 208 | (define (replace-op scope p lines char) 209 | (define (char-string str) 210 | (make-string (string-length str) char)) 211 | (g-proc scope p lines char-string)) 212 | 213 | (module+ test 214 | (let-values ([(p lines diffs) 215 | (g~-op (Scope (Point 0 1 1) (Point 1 2 2) #t #f 'block) 216 | (Point 0 4 4) '("two" "another."))]) 217 | (check-equal? p (Point 0 1 1)) 218 | (check-equal? lines '("tWo" "aNother.")) 219 | (check-equal? diffs 220 | (list 221 | (Diff-item 222 | (Region (Scope (Point 0 1 1) (Point 1 2 2) #t #f 'block) '("w" "n")) 223 | (Region (Scope (Point 0 1 1) (Point 1 2 2) #t #f 'block) '("W" "N")))))) 224 | (let-values ([(p lines diffs) 225 | (gU-op (Scope (Point 0 1 1) (Point 1 5 5) #t #f 'block) 226 | (Point 0 4 4) '("two" "another."))]) 227 | (check-equal? p (Point 0 1 1)) 228 | (check-equal? lines '("tWO" "aNOTHer.")) 229 | (check-equal? diffs 230 | (list 231 | (Diff-item 232 | (Region (Scope (Point 0 1 1) (Point 1 5 5) #t #f 'block) '("wo" "noth")) 233 | (Region (Scope (Point 0 1 1) (Point 1 5 5) #t #f 'block) '("WO" "NOTH")))))) 234 | (let-values ([(p lines diffs) 235 | (gu-op (Scope (Point 0 1 1) (Point 1 5 5) #t #f 'block) 236 | (Point 0 4 4) '("TWO" "ANOTHER."))]) 237 | (check-equal? p (Point 0 1 1)) 238 | (check-equal? lines '("Two" "AnothER.")) 239 | (check-equal? diffs 240 | (list 241 | (Diff-item 242 | (Region (Scope (Point 0 1 1) (Point 1 5 5) #t #f 'block) '("WO" "NOTH")) 243 | (Region (Scope (Point 0 1 1) (Point 1 5 5) #t #f 'block) '("wo" "noth")))))) 244 | (let-values ([(p lines diffs) 245 | (gU-op (Scope (Point 1 7 7) (Point 2 8 8) #t #t 'block) 246 | (Point 1 7 7)'("so were thee" "of Atreus, " "another."))]) 247 | (check-equal? p (Point 1 7 7)) 248 | (check-equal? lines '("so were thee" "of AtreUS, " "another.")) 249 | (check-equal? diffs 250 | (list 251 | (Diff-item 252 | (Region (Scope (Point 1 7 7) (Point 2 8 8) #t #t 'block) '("us" ".")) 253 | (Region (Scope (Point 1 7 7) (Point 2 9 9) #t #f 'block) '("US" "."))))))) 254 | 255 | (define (insert pp inserted-lines lines mode) 256 | (define-values (new-p new-lines) (insert-lines-at pp lines inserted-lines mode)) 257 | (define insert-diffs (get-insert-diffs pp inserted-lines mode)) 258 | (values new-p new-lines insert-diffs)) 259 | 260 | (module+ test 261 | (let-values ([(p lines diffs) 262 | (insert (Point 0 1 1) 263 | '("123" "456") 264 | '("two" "another.") 265 | 'char)]) 266 | (check-equal? p (Point 1 3 3)) 267 | (check-equal? lines '("t123" "456wo" "another.")) 268 | (check-equal? diffs 269 | (list 270 | (Diff-item 271 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'char) '()) 272 | (Region 273 | (Scope (Point 0 1 1) (Point 1 3 3) #t #f 'char) 274 | '("123" "456")))))) 275 | (let-values ([(p lines diffs) 276 | (insert (Point 0 1 1) 277 | '("123" "456") 278 | '("two" "another.") 279 | 'block)]) 280 | (check-equal? p (Point 0 1 1)) 281 | (check-equal? lines '("t123wo" "a456nother.")) 282 | (check-equal? diffs 283 | (list 284 | (Diff-item 285 | (Region (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'block) '()) 286 | (Region (Scope (Point 0 1 1) (Point 1 4 4) #t #f 'block) '("123" "456"))))))) 287 | 288 | ; todo Join 'J 289 | 290 | (define (key-to-operator char) 291 | (match char 292 | ['y yank-op] 293 | ['d delete-op] 294 | ['x delete-op] 295 | ['p post-paste-op] 296 | ['P pre-paste-op] 297 | ['> right-shift-op] 298 | ['< left-shift-op] 299 | ['c 'change-op] 300 | [_ (error (~e 'missing-case-in-key-to-operator char))])) 301 | 302 | (define (key-to-operator-without-prefix char [throw? #t]) 303 | (match char 304 | ['y yank-op] 305 | ['d delete-op] 306 | ['x delete-op] 307 | ['p post-paste-op] 308 | ['P pre-paste-op] 309 | ['> right-shift-op] 310 | ['< left-shift-op] 311 | ['c 'change-op] 312 | ['u gu-op] 313 | ['U gU-op] 314 | ['~ g~-op] 315 | [_ (and throw? (error (~e 'missing-case-in-key-to-operator-without-prefix char)))])) 316 | 317 | (define (key-to-g-op k) 318 | (match k 319 | ['g~ g~-op] 320 | ['gu gu-op] 321 | ['gU gU-op] 322 | [_ (error 'missing-case-in-key-to-g-op)])) 323 | 324 | -------------------------------------------------------------------------------- /params.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | 4 | (struct Command (op start-motions-lst scope-motions inserted-lines) #:transparent) 5 | 6 | (define (make-Command op scope-motions #:op-params [op-params '()] #:start-motions-lst [start-motions-lst '()]) 7 | (Command op start-motions-lst scope-motions op-params)) 8 | 9 | -------------------------------------------------------------------------------- /reg-manager.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module+ test 4 | (require rackunit)) 5 | 6 | (provide (struct-out Reg) reg-manager% make-Reg) 7 | 8 | (struct Reg (lines mode) #:transparent) 9 | 10 | (define (make-Reg lines [mode 'char]) 11 | (Reg lines mode)) 12 | 13 | (define reg-manager% 14 | (class object% 15 | (super-new) 16 | (define yank-reg (make-Reg '())) 17 | 18 | (define last-command #f) 19 | 20 | (define last-motions #f) 21 | 22 | (define last-search-motions #f) 23 | 24 | (define named-regs (make-hash)) 25 | 26 | ; marks separate from regs 27 | (define local-marks (make-vector 26)) 28 | (define global-marks (make-vector 26)) 29 | (define special-marks (make-hash)) 30 | 31 | (define/public (get-reg name) 32 | (match name 33 | ['yank yank-reg] 34 | ['last-cmd last-command] 35 | ['last-motions last-motions] 36 | ['last-search-motions last-search-motions] 37 | [_ (error 'missing-case-in-get-reg)])) 38 | 39 | (define/public (set-reg name reg) 40 | (match name 41 | ['yank (set! yank-reg reg)] 42 | ['last-cmd (set! last-command reg)] 43 | ['last-motions (set! last-motions reg)] 44 | ['last-search-motions (set! last-search-motions reg)] 45 | [_ (error 'missing-case-in-set-reg)])) 46 | 47 | (define/public (get-yank-reg) 48 | (get-reg 'yank)) 49 | 50 | (define/public (set-yank-reg reg) 51 | (set-reg 'yank reg)) 52 | 53 | (define/public (get-last-cmd) 54 | (get-reg 'last-cmd)) 55 | 56 | (define/public (set-last-cmd reg) 57 | (set-reg 'last-cmd reg)) 58 | 59 | (define/public (get-last-motions) 60 | (get-reg 'last-motions)) 61 | 62 | (define/public (set-last-motions reg) 63 | (set-reg 'last-motions reg)) 64 | 65 | (define/public (get-last-search-motions) 66 | (get-reg 'last-search-motions)) 67 | 68 | (define/public (set-last-search-motions! reg) 69 | (set-reg 'last-search-motions reg)) 70 | 71 | (define/public (get-mark char) 72 | (cond 73 | [(char-alphabetic? char) 74 | (cond 75 | [(char-lower-case? char) 76 | (define index (- (char->integer char) (char->integer #\a))) 77 | (vector-ref local-marks index)] 78 | [(char-upper-case? char) 79 | (define index (- (char->integer char) (char->integer #\A))) 80 | (vector-ref global-marks index)])] 81 | [else (hash-ref special-marks char)])) 82 | 83 | (define/public (set-mark! char point) 84 | (cond 85 | [(char-alphabetic? char) 86 | (cond 87 | [(char-lower-case? char) 88 | (define index (- (char->integer char) (char->integer #\a))) 89 | (vector-set! local-marks index point)] 90 | [(char-upper-case? char) 91 | (define index (- (char->integer char) (char->integer #\A))) 92 | (vector-set! global-marks index point)])] 93 | [else (hash-set! special-marks char point)])) 94 | 95 | (define/public (get-named-reg char) 96 | (hash-ref named-regs char)) 97 | 98 | (define/public (set-named-reg! char reg) 99 | (hash-set! named-regs char reg)) 100 | )) 101 | -------------------------------------------------------------------------------- /scope.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | (require "core.rkt" "move.rkt") 3 | 4 | (provide (all-defined-out)) 5 | 6 | (module+ test (require typed/rackunit)) 7 | 8 | ; #t for dir means -> 9 | (struct Scope ([start : Point] [end : Point] [dir : Boolean] [include-real-end? : Boolean] [mode : Symbol]) #:transparent) 10 | 11 | (: line-scope (-> Point String Scope)) 12 | (define (line-scope p l) 13 | (Scope p p #t #t 'line)) 14 | 15 | (: left-scope (-> Point Natural Scope)) 16 | (define (left-scope p count) 17 | (Scope (left-point p count) p #f #f 'char)) 18 | 19 | (: right-scope* (-> Point String Natural Scope)) 20 | (define (right-scope* p l count) 21 | (define right-p (right-point* p l count)) 22 | (Scope p right-p #t #f 'char)) 23 | 24 | (: up-scope (-> Point (Listof String) Natural Scope)) 25 | (define (up-scope p lines count) 26 | (Scope (up-point p lines count) p #f #f 'char)) 27 | 28 | (: down-scope (-> Point (Listof String) Natural Scope)) 29 | (define (down-scope p lines count) 30 | (Scope p (down-point p lines count) #t #f 'char)) 31 | 32 | (: up-scope-line-mode (-> Point (Listof String) Natural Scope)) 33 | (define (up-scope-line-mode p lines count) 34 | (Scope (up-point p lines count) p #f #t 'line)) 35 | 36 | (: down-scope-line-mode (-> Point (Listof String) Natural Scope)) 37 | (define (down-scope-line-mode p lines count) 38 | (Scope p (down-point p lines count) #t #t 'line)) 39 | 40 | (: line-end-scope (-> Point String Scope)) 41 | (define (line-end-scope p l) 42 | (Scope p (line-end-point (Point-row p) l) #t #t 'char)) 43 | 44 | (: after-line-end-scope (-> Point String Scope)) 45 | (define (after-line-end-scope p l) 46 | (Scope p (after-line-end-point (Point-row p) l) #t #f 'char)) 47 | 48 | (: line-start-scope (-> Point Scope)) 49 | (define (line-start-scope p) 50 | (Scope (line-start-point (Point-row p)) p #f #f 'char)) 51 | 52 | (: line-scope-scope (-> Point String Scope)) 53 | (define (line-scope-scope p l) 54 | (define row (Point-row p)) 55 | (Scope (line-start-point row) (line-end-point row l) #t #t 'char)) 56 | 57 | (: e-scope (-> Point String Natural Scope)) 58 | (define (e-scope p l count) 59 | (Scope p (e-point p l count) #t #t 'char)) 60 | 61 | (: E-scope (-> Point String Natural Scope)) 62 | (define (E-scope p l count) 63 | (Scope p (E-point p l count) #t #t 'char)) 64 | 65 | (: w-scope (-> Point String Natural Scope)) 66 | (define (w-scope p l count) 67 | (Scope p (before-w-point p l count) #t #t 'char)) 68 | 69 | (: i-w-scope (-> Point String Natural Scope)) ;;; buggy when start at space 70 | (define (i-w-scope p l count) 71 | (define pred (Point-char-pred p l)) 72 | (define p-start (left-cont-last-if-point pred p l)) 73 | (define w-p (w-point p l (cast (sub1 count) Natural))) 74 | (define p-end (right-cont-last-if-point pred w-p l)) 75 | (Scope p-start p-end #t #t 'char)) 76 | 77 | (module+ test 78 | (check-equal? (i-w-scope (Point 1 4 1) "abc def" 1) 79 | (Scope (Point 1 4 1) (Point 1 6 6) #t #t 'char)) 80 | (check-equal? (i-w-scope (Point 1 2 1) "abc def" 1) 81 | (Scope (Point 1 0 0) (Point 1 2 1) #t #t 'char)) 82 | (check-equal? (i-w-scope (Point 1 0 1) "abc" 1) 83 | (Scope (Point 1 0 1) (Point 1 2 2) #t #t 'char))) 84 | 85 | (: a-w-scope (-> Point String Natural Scope)) 86 | (define (a-w-scope p l count) 87 | (define start-pred (Point-char-pred p l)) 88 | (define p-start (left-cont-last-if-point start-pred p l)) 89 | (define w-p (w-point p l (cast (sub1 count) Natural))) 90 | (define p-end (before-w-point w-p l)) 91 | (Scope p-start p-end #t #t 'char)) 92 | 93 | (module+ test 94 | (check-equal? (a-w-scope (Point 1 4 1) "abc def" 1) 95 | (Scope (Point 1 4 1) (Point 1 6 6) #t #t 'char)) 96 | (check-equal? (a-w-scope (Point 1 2 1) "abc def" 1) 97 | (Scope (Point 1 0 0) (Point 1 3 3) #t #t 'char)) 98 | (check-equal? (a-w-scope (Point 1 0 1) "abc" 1) 99 | (Scope (Point 1 0 1) (Point 1 2 2) #t #t 'char)) 100 | (check-equal? (a-w-scope (Point 1 2 1) "abc def " 2) 101 | (Scope (Point 1 0 0) (Point 1 6 6) #t #t 'char))) ; buggy 102 | 103 | (: W-scope (-> Point String Natural Scope)) 104 | (define (W-scope p l count) 105 | (Scope p (before-W-point p l count) #t #t 'char)) 106 | 107 | (: i-W-scope (-> Point String Natural Scope)) 108 | (define (i-W-scope p l count) 109 | (define p-start (left-cont-last-if-point (negate char-whitespace?) p l)) 110 | (define W-p (W-point p l 111 | (cast (sub1 count) Natural))) 112 | (define p-end (right-cont-last-if-point (negate char-whitespace?) W-p l)) 113 | (Scope p-start p-end #t #t 'char)) 114 | 115 | (module+ test 116 | (check-equal? (i-W-scope (Point 1 4 1) "abc de," 1) 117 | (Scope (Point 1 4 1) (Point 1 6 6) #t #t 'char)) 118 | (check-equal? (i-W-scope (Point 1 2 1) "ab, def" 1) 119 | (Scope (Point 1 0 0) (Point 1 2 1) #t #t 'char)) 120 | (check-equal? (i-W-scope (Point 1 0 1) "ab," 1) 121 | (Scope (Point 1 0 1) (Point 1 2 2) #t #t 'char)) 122 | (check-equal? (i-W-scope (Point 1 2 1) "ab, def" 2) 123 | (Scope (Point 1 0 0) (Point 1 6 6) #t #t 'char)) 124 | (check-equal? (i-W-scope (Point 1 0 1) "ab," 2) 125 | (Scope (Point 1 0 1) (Point 1 2 2) #t #t 'char))) 126 | 127 | (: a-W-scope (-> Point String Natural Scope)) 128 | (define (a-W-scope p l count) 129 | (define p-start (left-cont-last-if-point (negate char-whitespace?) p l)) 130 | (define W-p (W-point p l 131 | (cast (sub1 count) Natural))) 132 | (define p-end (before-W-point W-p l)) 133 | (Scope p-start p-end #t #t 'char)) 134 | 135 | (module+ test 136 | (check-equal? (a-W-scope (Point 1 4 1) "abc de," 1) 137 | (Scope (Point 1 4 1) (Point 1 6 6) #t #t 'char)) 138 | (check-equal? (a-W-scope (Point 1 2 1) "ab, def" 1) 139 | (Scope (Point 1 0 0) (Point 1 3 3) #t #t 'char)) 140 | (check-equal? (a-W-scope (Point 1 0 1) "ab," 1) 141 | (Scope (Point 1 0 1) (Point 1 2 2) #t #t 'char)) 142 | (check-equal? (a-W-scope (Point 1 2 1) "ab, def" 2) 143 | (Scope (Point 1 0 0) (Point 1 6 6) #t #t 'char)) 144 | (check-equal? (a-W-scope (Point 1 2 1) "ab, def gh" 2) 145 | (Scope (Point 1 0 0) (Point 1 7 7) #t #t 'char))) 146 | 147 | (: b-scope (-> Point String Natural Scope)) 148 | (define (b-scope p l count) 149 | (Scope (b-point p l count) p #f #t 'char)) 150 | 151 | (: B-scope (-> Point String Natural Scope)) 152 | (define (B-scope p l count) 153 | (Scope (B-point p l count) p #f #t 'char)) 154 | 155 | (: t-scope (-> Char Point String Natural Scope)) 156 | (define (t-scope k p l count) 157 | (Scope p (t-point k p l count) #t #t 'char)) 158 | 159 | (: f-scope (-> Char Point String Natural Scope)) 160 | (define (f-scope k p l count) 161 | (Scope p (f-point k p l count) #t #t 'char)) 162 | 163 | (: T-scope (-> Char Point String Natural Scope)) 164 | (define (T-scope k p l count) 165 | (Scope (T-point k p l count) p #f #t 'char)) 166 | 167 | (: F-scope (-> Char Point String Natural Scope)) 168 | (define (F-scope k p l count) 169 | (Scope (F-point k p l count) p #f #t 'char)) 170 | 171 | (: G-scope (-> Point (Listof String) Scope)) 172 | (define (G-scope p lines) 173 | (Scope p (G-point lines) #t #t 'line)) 174 | 175 | (module+ test 176 | (check-equal? (G-scope (Point 0 0 0) (list)) (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'line)) 177 | (check-equal? (G-scope (Point 0 0 0) (list "abc")) (Scope (Point 0 0 0) (Point 0 0 0) #t #t 'line)) 178 | (check-equal? (G-scope (Point 0 1 1) (list "abc" "")) (Scope (Point 0 1 1) (Point 1 0 0) #t #t 'line)) 179 | (check-equal? (G-scope (Point 1 1 1) (list "a" "b" "c")) (Scope (Point 1 1 1) (Point 2 0 0) #t #t 'line))) 180 | 181 | (: lines-scope (->* (Point Lines) (Symbol) Scope)) 182 | (define (lines-scope start lines [mode 'char]) 183 | (define end (after-lines-point start lines mode)) 184 | (Scope start end #t #f mode)) 185 | -------------------------------------------------------------------------------- /search.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "core.rkt") 4 | 5 | (provide search) 6 | 7 | (define (search p lines command direction count inclusive?) 8 | (define command-pattern 9 | (match direction 10 | ['forwards #px"^(.*?)(?:/(.*))?$"] 11 | ['backwards #px"^(.*?)(?:\\?(.*))?$"] 12 | [_ (error 'missing-case)])) 13 | (match-define (list _ pattern-str offset-str) (regexp-match command-pattern command)) 14 | (define pattern (pregexp pattern-str)) 15 | (define range (search-impl p lines pattern direction count inclusive?)) 16 | (define offset (cond 17 | [offset-str (string->number offset-str)] 18 | [else #f])) 19 | (cond 20 | [(not (and range offset)) range] 21 | [else 22 | 23 | (define start-row (Point-row (first range))) 24 | (define new-row (min (sub1 (length lines)) (+ start-row offset))) 25 | (define offsetted-p (Point new-row 0 0)) 26 | (cons offsetted-p range)] 27 | )) 28 | 29 | (define (search-impl p lines pattern direction count inclusive?) 30 | (define search-func 31 | (match direction 32 | ['forwards search-forwards] 33 | ['backwards search-backwards] 34 | [_ (error 'missing-case)])) 35 | (for/fold ([p-pp (list p p)]) 36 | [(i (in-range count))] 37 | (search-func (first p-pp) lines pattern inclusive?))) 38 | 39 | (define (search-string-forwards row str pattern [col-inc 0]) 40 | (define pair (regexp-match-positions pattern str)) 41 | (cond 42 | [(not pair) #f] 43 | [else 44 | (define p (first pair)) 45 | (define col0 (+ (car p) col-inc)) 46 | (define col1 (+ (cdr p) col-inc)) 47 | (list (Point row col0 col0) (Point row col1 col1))])) 48 | 49 | (define (search-string-backwards row str pattern [col-inc 0]) 50 | (define pair (regexp-match-positions* pattern str)) 51 | (cond 52 | [(empty? pair) #f] 53 | [else 54 | (define p (last pair)) 55 | (define col0 (+ (car p) col-inc)) 56 | (define col1 (+ (cdr p) col-inc)) 57 | (list (Point row col0 col0) (Point row col1 col1))])) 58 | 59 | (define (search-forwards p lines pattern inclusive?) 60 | (match-define (Point row col _) p) 61 | (define use-col (if inclusive? col (add1 col))) 62 | (define line (list-ref lines row)) 63 | (define (search-the-line) 64 | (define rest-str (substring line use-col)) 65 | (search-string-forwards row rest-str pattern use-col)) 66 | (cond 67 | [(search-the-line)] 68 | [(for/or ([l (drop lines (add1 row))] 69 | [new-row (in-naturals (add1 row))]) 70 | (search-string-forwards new-row l pattern))] 71 | [else 72 | (define begin-to-point 73 | (append (take lines row) 74 | (list (substring line 0 use-col)))) 75 | (for/or ([l begin-to-point] 76 | [new-row (in-naturals)]) 77 | (search-string-forwards new-row l pattern))] 78 | )) 79 | 80 | (define (search-backwards p lines pattern inclusive?) 81 | (match-define (Point row col _) p) 82 | (define use-col (if inclusive? (add1 col) col)) 83 | (define line (list-ref lines row)) 84 | (define (search-the-line) 85 | (define rest-str (substring line use-col)) 86 | (search-string-backwards row rest-str pattern use-col)) 87 | (cond 88 | [(let ([begin-to-point 89 | (append (take lines row) 90 | (list (substring line 0 use-col)))]) 91 | (for/or ([l (reverse begin-to-point)] 92 | [new-row (in-range (sub1 (length begin-to-point)) -1 -1)]) 93 | (search-string-backwards new-row l pattern)))] 94 | [(for/or ([l (reverse (drop lines (add1 row)))] 95 | [new-row (in-range (sub1 (length lines)) row -1)]) 96 | (search-string-backwards new-row l pattern))] 97 | [else (search-the-line)] 98 | )) 99 | -------------------------------------------------------------------------------- /substitude.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide substitude-from-point-to-line substitude-within-range substitude-once) 4 | 5 | (require "core.rkt" "common-utils.rkt" "wrapped-move-scope.rkt" "diff.rkt" "diff-utils.rkt") 6 | 7 | (define (substitude-line-from-col src dst line col mode) 8 | (define substitude-func 9 | (match mode 10 | ['first regexp-replace] 11 | ['all regexp-replace*] 12 | [_ (error 'missing-case)])) 13 | (string-append 14 | (substring line 0 col) 15 | (substitude-func src (substring line col) dst))) 16 | 17 | (define (diff-for-each-line row new-line lines) 18 | (define start (Point row 0 0)) 19 | (define scope (Scope start start #t #t 'line)) 20 | (get-replace-diffs scope start (list new-line) 'line lines)) 21 | 22 | (define (substitude-from-point-to-line src dst p end-line lines mode) 23 | (define-values (row col) (Point-row-col p)) 24 | (define-values (_ this after) (before-this-after (take lines (add1 end-line)) row)) 25 | (define new-this (substitude-line-from-col src dst this col mode)) 26 | (define this-diff-lst 27 | (cond 28 | [(equal? this new-this) '()] 29 | [else (diff-for-each-line row new-this lines)])) 30 | (define new-diff-lst 31 | (for/fold ([diff-lst this-diff-lst]) 32 | ([l after] 33 | [r (in-naturals (add1 row))]) 34 | (define new-l (substitude-line-from-col src dst l 0 mode)) 35 | (cond 36 | [(equal? l new-l) diff-lst] 37 | [else (define new-diffs (diff-for-each-line r new-l lines)) 38 | (append new-diffs diff-lst)]))) 39 | (define-values (__ new-lines) (redo-diffs new-diff-lst lines)) 40 | (values new-lines new-diff-lst)) 41 | 42 | ; end-line inclusive. 43 | (define (substitude-within-range src dst start-line end-line lines mode) 44 | (define ranged-lines (drop (take lines (add1 end-line)) start-line)) 45 | (define diffs 46 | (for/fold ([diff-lst '()]) 47 | ([l ranged-lines] 48 | [r (in-naturals start-line)]) 49 | (define new-l (substitude-line-from-col src dst l 0 mode)) 50 | (cond 51 | [(equal? l new-l) diff-lst] 52 | [else (define new-diffs (diff-for-each-line r new-l lines)) 53 | (append new-diffs diff-lst)]))) 54 | (define-values (__ new-lines) (redo-diffs diffs lines)) 55 | (values new-lines diffs)) 56 | 57 | (define (substitude-once src dst p lines) 58 | (define-values (row col) (Point-row-col p)) 59 | (define old-line (list-ref lines row)) 60 | (define new-line (substitude-line-from-col src dst old-line col 'first)) 61 | (define diff-lst 62 | (cond 63 | [(equal? old-line new-line) '()] 64 | [else (diff-for-each-line row new-line lines)])) 65 | (define-values (__ new-lines) (redo-diffs diff-lst lines)) 66 | (values new-lines diff-lst)) 67 | -------------------------------------------------------------------------------- /wrapped-move-scope.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (provide after-lines-point Scoped-lines (struct-out Point) (struct-out Scope) lines-scope) 6 | 7 | (require "core.rkt" "move.rkt" "scope.rkt") 8 | 9 | (require/typed "search.rkt" [search (-> Point Lines String Symbol Natural Boolean (Listof Point))]) 10 | 11 | (require/typed "match-paren.rkt" [%-point (-> Point Lines Point)]) 12 | 13 | (module+ test (require typed/rackunit)) 14 | 15 | (struct Motion ([motion : Symbol] [char : (U Char String #f)] [count : (Option Natural)]) #:transparent) 16 | 17 | (struct Visual-Motion ([row : Natural] [col : Natural] [mode : Symbol]) #:transparent) 18 | 19 | (struct Mark-Motion ([point : Point]) #:transparent) 20 | 21 | (: make-Motion (->* (Symbol) ((U Char String #f) #:count (Option Natural)) Motion)) 22 | (define (make-Motion motion [char #f] #:count [count #f]) 23 | (Motion motion char count)) 24 | 25 | (module+ test 26 | (check-equal? (make-Motion 'e) (Motion 'e #f #f)) 27 | (check-equal? (make-Motion 'f #\x) (Motion 'f #\x #f)) 28 | (check-equal? (make-Motion 'e #:count 2) (Motion 'e #f 2)) 29 | (check-equal? (make-Motion 'f #\x #:count 3) (Motion 'f #\x 3))) 30 | 31 | (: search-point (-> Point Lines String Symbol Natural Point)) 32 | (define (search-point p lines pattern direction count) 33 | (define range (search p lines pattern direction count #f)) 34 | (unless range (error 'not-result)) 35 | (first range)) 36 | 37 | (: search-scope (-> Point Lines String Symbol Natural Scope)) 38 | (define (search-scope p lines pattern direction count) 39 | (define new-p (search-point p lines pattern direction count)) 40 | (Scope p new-p #t #f 'char)) 41 | 42 | (: move-point (-> (U Motion Mark-Motion) Point Lines Point)) 43 | (define (move-point motions p lines) 44 | ;(displayln (~e 'move-point motions p lines)) 45 | (define-values (row col) (Point-row-col p)) 46 | (define line 47 | (if (empty? lines) 48 | "" 49 | (list-ref lines row))) 50 | (cond 51 | [(Mark-Motion? motions) (Mark-Motion-point motions)] 52 | [else 53 | (match-define (Motion motion char optional-count) motions) 54 | (define count (or optional-count 1)) 55 | (match motion 56 | ['left (left-point p count)] 57 | ['right (right-point p line count)] 58 | ['right* (right-point* p line count)] 59 | ['e (e-point p line count)] 60 | ['E (E-point p line count)] 61 | ['w (w-point p line count)] 62 | ['W (W-point p line count)] 63 | ['b (b-point p line count)] 64 | ['B (B-point p line count)] 65 | ['|0| (line-start-point row)] 66 | ['^ (^-point row line)] 67 | ['$ ($-point row lines count)] 68 | ['$* ($-point* row lines count)] 69 | ['t 70 | (define c (cast char Char)) 71 | (t-point c p line count)] 72 | ['T 73 | (define c (cast char Char)) 74 | (T-point c p line count)] 75 | ['f 76 | (define c (cast char Char)) 77 | (f-point c p line count)] 78 | ['F 79 | (define c (cast char Char)) 80 | (F-point c p line count)] 81 | ['up (up-point p lines count)] 82 | ['down (down-point p lines count)] 83 | ['up* (up-point* p lines count)] 84 | ['down* (down-point* p lines count)] 85 | ['G (G-point lines)] 86 | ['nope p] 87 | ['search-forwards (define pattern (cast char String)) 88 | (search-point p lines pattern 'forwards count)] 89 | ['search-backwards (define pattern (cast char String)) 90 | (search-point p lines pattern 'backwards count)] 91 | ['% #:when (not optional-count) (%-point p lines)] 92 | ['% #:when optional-count 93 | (n%-point lines count)] 94 | ['\| (\|-point row line count)] 95 | [_ (error 'move-point-missing-case (~a motion))])])) 96 | 97 | (module+ test 98 | (check-equal? (move-point (make-Motion 'right #:count 2) (Point 0 0 0) '("abc")) (Point 0 2 2)) 99 | (check-equal? (move-point (make-Motion 'e) (Point 0 0 0) '("abc")) (Point 0 2 2)) 100 | (check-equal? (move-point (make-Motion 't #\x) (Point 0 0 0) '("abc")) (Point 0 0 0))) 101 | 102 | (: get-point-scope (-> (U Motion Visual-Motion Mark-Motion) Point Lines Scope)) 103 | (define (get-point-scope motions p lines) 104 | (match motions 105 | [(Motion _ _ _) (get-point-scope-from-motion motions p lines)] 106 | [(Visual-Motion _ _ _) (get-point-scope-from-visual-motion motions p lines)] 107 | [(Mark-Motion pp) 108 | (define points 109 | (sort (list p pp) Point Visual-Motion Point Lines Scope)) 114 | (define (get-point-scope-from-visual-motion rel-motion p lines) 115 | (define-values (row col) (Point-row-col p)) 116 | (match-define (Visual-Motion rel-row rel-col mode) rel-motion) 117 | (define end 118 | (cond 119 | [(equal? mode 'char) 120 | (define start-p (Point row 0 0)) 121 | (define temp-p (move-point (make-Motion 'down #:count rel-row) start-p lines)) 122 | (move-point (make-Motion 'right #:count rel-col) temp-p lines)] 123 | [(equal? mode 'block) 124 | (define new-row (cast (min (+ rel-row row) (sub1 (length lines))) Natural)) 125 | (Point new-row (+ rel-col col) (+ rel-col col))] 126 | [else (error 'missing-case)])) 127 | (Scope p end #t #f mode)) 128 | 129 | (require/typed "match-paren.rkt" 130 | [a-paren-pair (-> (Pairof Char Char) Point Lines Natural (Pairof Point Point))]) 131 | 132 | (: a-paren-scope (-> (Pairof Char Char) Point Lines Natural Scope)) 133 | (define (a-paren-scope paren-pair p lines count) 134 | (define pair (a-paren-pair paren-pair p lines count)) 135 | (Scope (car pair) (cdr pair) #t #t 'char)) 136 | 137 | (: i-paren-scope (-> (Pairof Char Char) Point Lines Natural Scope)) 138 | (define (i-paren-scope paren-pair p lines count) 139 | (define pair (a-paren-pair paren-pair p lines count)) 140 | (define new-start 141 | (move-point (make-Motion 'right* #:count 1) (car pair) lines)) 142 | (Scope new-start (cdr pair) #t #f 'char)) 143 | 144 | (: a-b-scope (-> Point Lines Natural Scope)) 145 | (define (a-b-scope p lines count) 146 | (a-paren-scope '(#\( . #\)) p lines count)) 147 | 148 | (: a-\[-scope (-> Point Lines Natural Scope)) 149 | (define (a-\[-scope p lines count) 150 | (a-paren-scope '(#\[ . #\]) p lines count)) 151 | 152 | (: a-B-scope (-> Point Lines Natural Scope)) 153 | (define (a-B-scope p lines count) 154 | (a-paren-scope '(#\{ . #\}) p lines count)) 155 | 156 | (: a-\<-scope (-> Point Lines Natural Scope)) 157 | (define (a-\<-scope p lines count) 158 | (a-paren-scope '(#\< . #\>) p lines count)) 159 | 160 | (: i-b-scope (-> Point Lines Natural Scope)) 161 | (define (i-b-scope p lines count) 162 | (i-paren-scope '(#\( . #\)) p lines count)) 163 | 164 | (: i-\[-scope (-> Point Lines Natural Scope)) 165 | (define (i-\[-scope p lines count) 166 | (i-paren-scope '(#\[ . #\]) p lines count)) 167 | 168 | (: i-B-scope (-> Point Lines Natural Scope)) 169 | (define (i-B-scope p lines count) 170 | (i-paren-scope '(#\{ . #\}) p lines count)) 171 | 172 | (: i-\<-scope (-> Point Lines Natural Scope)) 173 | (define (i-\<-scope p lines count) 174 | (i-paren-scope '(#\< . #\>) p lines count)) 175 | 176 | (: get-point-scope-from-motion (-> Motion Point Lines Scope)) 177 | (define (get-point-scope-from-motion motions p lines) 178 | (define-values (row col) (Point-row-col p)) 179 | (define line 180 | (if (or (empty? lines) (equal? row (length lines))) 181 | "" 182 | (list-ref lines row))) 183 | (match-define (Motion motion char optional-count) motions) 184 | (define count (or optional-count 1)) 185 | (match motion 186 | ['nope (Scope p p #t #f 'char)] 187 | ['left (left-scope p count)] 188 | ['right (right-scope* p line count)] 189 | ['right* (right-scope* p line count)] 190 | ['e (e-scope p line count)] 191 | ['E (E-scope p line count)] 192 | ['w (w-scope p line count)] 193 | ['W (W-scope p line count)] 194 | ['iw (i-w-scope p line count)] 195 | ['iW (i-W-scope p line count)] 196 | ['aw (a-w-scope p line count)] 197 | ['aW (a-W-scope p line count)] 198 | ['ib (i-b-scope p lines count)] 199 | ['i\[ (i-\[-scope p lines count)] 200 | ['iB (i-B-scope p lines count)] 201 | ['i< (i-<-scope p lines count)] 202 | ['ab (a-b-scope p lines count)] 203 | ['a\[ (a-\[-scope p lines count)] 204 | ['aB (a-B-scope p lines count)] 205 | ['a< (a-<-scope p lines count)] 206 | ['b (b-scope p line count)] 207 | ['B (B-scope p line count)] 208 | ['|0| (line-start-scope p)] 209 | ['$ (line-end-scope p line)] 210 | ['$* (after-line-end-scope p line)] 211 | ['t 212 | (define c (cast char Char)) 213 | (t-scope c p line count)] 214 | ['T 215 | (define c (cast char Char)) 216 | (T-scope c p line count)] 217 | ['f 218 | (define c (cast char Char)) 219 | (f-scope c p line count)] 220 | ['F 221 | (define c (cast char Char)) 222 | (F-scope c p line count)] 223 | ['up (up-scope p lines count)] 224 | ['down (down-scope p lines count)] 225 | ['up-line-mode (up-scope-line-mode p lines count)] 226 | ['down-line-mode (down-scope-line-mode p lines count)] 227 | ['G (G-scope p lines)] 228 | ['line (line-scope p line)] 229 | ['search-forwards (define pattern (cast char String)) 230 | (search-scope p lines pattern 'forwards count)] 231 | ['search-backwards (define pattern (cast char String)) 232 | (search-scope p lines pattern 'backwards count)] 233 | ['% #:when (not optional-count) 234 | (define pp (%-point p lines)) 235 | (define points 236 | (sort (list p pp) Point 'left] 258 | [' 'right] 259 | [' 'up-line-mode] 260 | [' 'down-line-mode] 261 | ['h 'left] 262 | ['l 'right] 263 | ['k 'up-line-mode] 264 | ['j 'down-line-mode] 265 | ['0 '|0|] 266 | ['^ '^] 267 | ['$ '$] 268 | ['e 'e] 269 | ['E 'E] 270 | ['b 'b] 271 | ['B 'B] 272 | ['w 'w] 273 | ['W 'W] 274 | ['G 'G] 275 | ['% '%] 276 | ['\| '\|] 277 | [_ #f])) 278 | 279 | (define (key-to-motion k) 280 | (match k 281 | [' 'left] 282 | [' 'right] 283 | [' 'up] 284 | [' 'down] 285 | ['h 'left] 286 | ['l 'right] 287 | ['k 'up] 288 | ['j 'down] 289 | ['\0 '\0] 290 | ['^ '^] 291 | ['$ '$] 292 | ['e 'e] 293 | ['E 'E] 294 | ['b 'b] 295 | ['B 'B] 296 | ['w 'w] 297 | ['W 'W] 298 | ['G 'G] 299 | ['% '%] 300 | ['\| '\|] 301 | [_ #f])) 302 | 303 | (define (key-to-ia-motion k i/a?) 304 | (cond 305 | [(equal? i/a? 'i) 306 | (match k 307 | ['w 'iw] 308 | ['W 'iW] 309 | [(or 'b '\( '\)) 'ib] 310 | [(or '\[ '\]) 'i\[] 311 | [(or 'B '\{ '\}) 'iB] 312 | [(or '< '>) 'i<] 313 | [_ #f])] 314 | [(equal? i/a? 'a) 315 | (match k 316 | ['w 'aw] 317 | ['W 'aW] 318 | [(or 'b '\( '\)) 'ab] 319 | [(or '\[ '\]) 'a\[] 320 | [(or 'B '\{ '\}) 'aB] 321 | [(or '< '>) 'a<] 322 | [_ #f])] 323 | [else (error (~a "incorrect i/a: " i/a?))])) 324 | 325 | (: equal-point? (-> Point Point Boolean)) 326 | (define (equal-point? point1 point2) 327 | (and (equal? (Point-row point1) (Point-row point2)) 328 | (equal? (Point-col point1) (Point-col point2)))) 329 | 330 | (: empty-scope? (-> Scope Boolean)) 331 | (define (empty-scope? scope) 332 | (match-define (Scope start end dir include-end? mode) scope) 333 | (cond 334 | [(equal? mode 'line) #f] 335 | [(and dir include-end?) #f] 336 | [(equal-point? start end) #t] 337 | [else #f])) 338 | 339 | (module+ test 340 | (check-equal? (empty-scope? (Scope (Point 0 1 1) (Point 0 1 1) #t #f 'char)) #t) 341 | (check-equal? (empty-scope? (Scope (Point 0 1 1) (Point 0 1 1) #t #t 'char)) #f) 342 | (check-equal? (empty-scope? (Scope (Point 0 1 1) (Point 0 2 2) #t #t 'char)) #f)) 343 | 344 | (: equal-scope? (-> Scope Scope Boolean)) 345 | (define (equal-scope? scope1 scope2) 346 | (equal? scope1 scope2)) 347 | 348 | 349 | (require "common-utils.rkt") 350 | 351 | (: Scoped-lines (-> Scope (Listof String) (Listof String))) 352 | (define (Scoped-lines scope lines) 353 | (match-define (Scope start end dir include-real-end? mode) scope) 354 | (cond 355 | [(empty-scope? scope) '()] 356 | [(equal? mode 'line) 357 | (define end-row (+ (Point-row end) (if include-real-end? 1 0))) 358 | (drop (take lines end-row) (Point-row start)) 359 | ] 360 | [(equal? mode 'block) 361 | (define-values (_ middle __) (before-middle-after lines (Point-row start) (add1 (Point-row end)))) 362 | (define col0 (Point-col start)) 363 | (define col1 (Point-col end)) 364 | (define col-min (min col0 col1)) 365 | (define col-max (max col0 col1)) 366 | (define end-col (+ col-max (if (and include-real-end? dir) 1 0))) 367 | (for/list : (Listof String) 368 | ([l middle]) 369 | (string-append 370 | (substring-in-range l col-min end-col)))] 371 | [else 372 | (define end-col (+ (Point-col end) (if (and include-real-end? dir) 1 0))) 373 | (cond 374 | [(equal? (Point-row start) (Point-row end)) 375 | (define line (list-ref lines (Point-row start))) 376 | (list (substring-in-range line (Point-col start) end-col))] 377 | [else 378 | (define-values (l0 l1 l2 l3 l4) (split-five-at lines (Point-row start) (Point-row end))) 379 | (define m1 (substring (first-or-empty-string l1) 380 | (Point-col start))) 381 | (define m3 (substring (first-or-empty-string l3) 0 end-col)) 382 | (append (list m1) l2 (list m3))])])) 383 | 384 | (module+ test 385 | (check-equal? (Scoped-lines (Scope (Point 0 1 0) (Point 0 2 0) #t #t 'char) (list "abc")) '("bc")) 386 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 0 0) #f #f 'char) (list "abc")) '()) 387 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 0 0) #f #t 'char) (list "abc")) '()) 388 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 0 0) #f #f 'line) (list "abc")) '()) 389 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 0 0) #f #t 'line) (list "abc")) '("abc")) 390 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 1 1) #f #f 'char) (list "abc")) '("a")) 391 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 1 1) #f #t 'char) (list "abc")) '("a")) 392 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 1 1) #f #f 'line) (list "abc")) '()) 393 | (check-equal? (Scoped-lines (Scope (Point 0 0 0) (Point 0 1 1) #f #t 'line) (list "abc")) '("abc")) 394 | (check-equal? (Scoped-lines (Scope (Point 0 1 1) (Point 1 1 1) #f #f 'char) (list "abc" "def")) '("bc" "d")) 395 | (check-equal? (Scoped-lines (Scope (Point 0 1 1) (Point 1 1 1) #f #t 'char) (list "abc" "def")) '("bc" "d")) 396 | (check-equal? (Scoped-lines (Scope (Point 0 1 1) (Point 1 1 1) #f #f 'line) (list "abc" "def")) '("abc")) 397 | (check-equal? (Scoped-lines (Scope (Point 0 1 1) (Point 1 1 1) #f #t 'line) (list "abc" "def")) '("abc" "def")) 398 | (check-equal? (Scoped-lines (Scope (Point 1 1 1) (Point 2 1 1) #f #f 'char) (list "abc" "def" "ghi" "jkl")) '("ef" "g"))) 399 | --------------------------------------------------------------------------------