├── .gitignore ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── TODO ├── info.rkt └── rackterm ├── constants.c ├── constants.sh ├── info.rkt ├── private ├── 256color.rkt ├── cell.rkt ├── console-code-parse.rkt ├── fun-terminal.rkt ├── pty.rkt ├── shell-trampoline.rkt ├── term-key-event.rkt ├── terminal-canvas.rkt └── terminal.rkt ├── rackterm.terminfo └── xterm.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | constants 3 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | 2 | I have big plans for this terminal emulator, but probably will not have a lot of time to work on it. I want to lay out my ideas here so that I'll remember them and so that potential contributors can understand where I intend the project to go. Feedback on these plans are welcome and encouraged - I would like to know other people's thoughts. I don't want to make a terminal emulator to just do what is already done, and I don't do everything in the terminal because I'm old-fashioned or some sort of luddite. I use terminals because it can be a much more powerful and efficient way of interacting with a computer than pointing around with the rat and clicking on the few options that can be visually displayed. I want to move away from a lot of the historical baggage of terminal emulators and their use that have grown since the 60s or 70s. So feel free to contribute ideas or code if you are a like-minded terminal lover. 3 | 4 | By the way, if you contribute code, it's currently somewhat a mess -- the rationale for actually starting this was to learn racket, and a bunch of the code is really gross as I threw it together as fast as I could while learning how to make things work. 5 | 6 | Reasonably Serious Plans 7 | ======================== 8 | 9 | * I want to clean up the parser and have it useful generally for programs that want to handle input with ANSI terminal codes. 10 | * I want to use the core library to make multiple frontends -- I want to have it back an xterm, a GUI terminal widget (canvas%, so far, that is used in the xterm, but can also be embedded in other gui programs if desired), a tmux/screen style console terminal emulator/multiplexer, and any other frontend (I imagine a weekend project of a framebuffer terminal, some day, or at some point being able to run racket on Android and replacing the no-longer-developed-or-accepting-new-features terminal for Android...). My plan is for the terminal object to keep track of all the state and the frontend will just draw it out and send input to it. 11 | * I want it to be very configurable (probably in racket code itself) - both the tmux/screen version and a future multiplexing xterm version will need various commands to split the view and open another terminal, switch over to another background window of terminals, do window management tasks, etc. I want the key configuration to have first class support for modality (a la vim -- if it's not there someone always wants to hack it in anyhow, eg. [tmuxmodality.py](https://github.com/mtl/tmux-modality)), and chains of keys (eg C-c C-n, like emacs has for so much stuff). The default config need not use either of those, but I'm quite sure I will use both. 12 | * I want there to be good configuration for mapping input characters to other things -- arrow keys, other named keys, function keys, etc need these weird mappings. You can also add mappings so you can use super and hyper modifiers in the terminal (like control and alt). I would also like to be able to map C-m and C-i, which are the same as return and tab, respectively. Then there is always the debate over whether the backspace key should send BS or DEL... 13 | * I would like the bulk of configuration to be able to be shared by the various frontends to rackterm, but individual modifications to be made to each. Also, the configuration should be able to source more than one file. A common pattern I use is to keep my main configuration for programs in my dotfiles, but source a local configuration file if it exists to add any extra configuration I need on a specific computer. Common differences may include font sizes, for example. 14 | * Since I want configuration to be in full racket, but many people like simple, weak configuration, perhaps it could load configuration in multiple formats, or there could be a #lang rackterm-config which would make it easy. The configuration could be loaded with some dynamic-require or perhaps xmonad-style by wrapping the original code with the configuration to make a new executable. 15 | * And, of course, I want all the expected terminal features that I don't have yet -- scrollback, mouse support, copy/paste with display server, etc. 16 | * And I'd like to have some sort of mode to, say, rather than spawning the child process itself and handling things the Unix way, it might be good to have it be able to connect to an actual serial input, or be an ssh terminal (eg. in place of putty on Windows), so I should add support for that at some point. 17 | * I would like to support Windows to be more cross-platform, but after spending some time trying to figure out where to start with that I gave up. I don't want to work too hard to support a platform that I hope dies. 18 | * I'd like it to not be super slow like it is now... though as long as it's "good enough" efficiency will probably be a secondary concern for me. 19 | 20 | 21 | 22 | Etherial Wishful Thinking Plans 23 | =============================== 24 | 25 | * I want to extend the capabilities of terminal emulators past what is currently done -- I want to add graphical elements in the forms of: 26 | - GUI cells (IE bitmaps can be drawn in cells that would normally hold characters) 27 | - overlays (IE drawn on an otherwise transparent layer above the characters. 28 | * This would allow for things such as: 29 | - drracket style drawing lines to show usages of a symbol 30 | - emacs, powerline, etc to draw weird pictures/glyphs without requiring special modified fonts 31 | - some people want to add gui symbols, controls, etc to console programs (I'm less on board here, because I hate anything that will end up requiring mouse interaction, but any well written program should be able to avoid that). 32 | - various other things I haven't even thought of, I'm sure 33 | * I want to get away from parsing crazy escape codes, and I want to get away from terminal capabilities being inferred by some third party database. The days are long gone when people connected a dumb hardware terminal to a serial port. Now every terminal is a smart terminal, so the terminal should be able to talk with the client program and simply tell it its capabilities. To do these, I want to add an embedded interpreter. There are codes that already accept a field of arbitrary text -- ESC ] ; . I want to add one that will be for evaluating... probably scheme, with added "terminal primitives" for all needed terminal operations. I figure R5RS or some such will be adoptable by other terminal emulators if the idea ever became popular, so code written to run on a rackterm can also work on other terminals that decide to implement it, via one of the myriad of embeddable schemes. This will have to be combined with a canonical format of sending any necessary responses back to the client -- it can just expect to receive a certain similar escape sequence soon after sending a request that needs a reply. The rationale behind having replies and such is so that a client can ask about capabilities of the interpreter (IE are you r5rs, r6rs...? Do you support italics? Do you support slanting the opposite way of italics? etc). 34 | - Of course, nobody is going to do that, so they would just be interesting experimental features of this specific terminal emulator. 35 | - What communication channel could the program and the terminal use to talk to each other? Current query/response features have the terminal respond by sending characters as if typed by the user. This would be a serious security issue if this were generalized to allow arbitrary query/response. But what else can you count on? Sockets sound good, but the program may be on the other side of an ssh session, and not have network access to get to the terminal. Maybe these sort of extended capabilities would only be available for programs run locally? That doesn't sound very appealing. So I'm not sure this is feasible in any way without essentially inventing an entirely new protocol and becoming something very different and incompatible with existing terminal technology. So this probably won't happen. 36 | 37 | 38 | 39 | Code Layout 40 | =========== 41 | 42 | For the moment, at least. This could be outdated later. 43 | 44 | At the center, the terminal emulator stores its state in a functional zipper, in `fun-terminal.rkt`. 45 | `cell.rkt` has the data structures for the character cells that the zipper holds. 46 | I parse console codes into s-expressions in `console-code-parse.rkt` 47 | `pty.rkt` has a bit of code for interfacing with the Unix PTY system. 48 | `shell-trampoline.rkt` is a little wrapper for spawned programs to be able to set some Unix stuff before actually executing the provided shell. 49 | `terminal.rkt` is in charge of communicating with the sub-process, interpreting the s-expressions to mutate the state, etc. Basically it is everything but some sort of (potentially graphical) visualization and UI. 50 | `terminal-canvas.rkt` provides a canvas% class that can be embedded in any Racket gui. 51 | `xterm.rkt` is a full-blown application that basically just wraps the canvas. 52 | 53 | I hope to improve the interfaces of these things to make it useful for any program to 54 | embed a terminal in its GUI if it wants, or parse ANSI console codes for some non-terminal 55 | use in some application, etc. 56 | 57 | 58 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Rackterm is distributed under the MIT license and the 2 | Apache version 2.0 license, at your option. 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Terminal emulator in racket! 2 | 3 | Install 4 | ------- 5 | 6 | You can install from the racket package system by running `raco pkg install rackterm`. If you want to get it straight from git, clone the repo, `cd` into it, and run `raco pkg install`. 7 | 8 | Run 9 | --- 10 | 11 | `racket -l rackterm/xterm --` 12 | or, if you have your racket/bin directory on your `$PATH`, run `rackterm-xterm` 13 | 14 | What is this? 15 | ------------- 16 | 17 | This is a terminal emulator with support for [24-bit color](https://gist.github.com/XVilka/8346728), italics, and more, written in Racket. 18 | 19 | It is a work in progress and is currently lacking many features which I hope to gradually add. Currently I can run emacs, vim, and other curses programs seemingly just fine. For an idea of where I want to take the project, see the CONTRIBUTING.md file. 20 | 21 | TERM variable 22 | ------------- 23 | 24 | The rackterm/xterm program runs the tic program on startup to load the rackterm terminfo definition. It starts with `TERM=rackterm`. This should work great. Unless you ssh to another machine, in which case the new host will not have the definition. You can either scp or otherwise copy the rackterm.terminfo file to the other machine and run `tic rackterm.terminfo` on it, or you can set `TERM=xterm` (perhaps by running with `--term-var xterm`). You will get fewer capabilities with `TERM=xterm`, like no italics, no extended color, etc, since programs won't know how to access those things, but you don't have to get the terminfo file onto all your machines that way. 25 | 26 | OS Support 27 | ---------- 28 | 29 | Rackterm is known to work on GNU/Linux, FreeBSD, and MacOSX. 30 | 31 | If it doesn't run on your system, open an issue at https://github.com/willghatch/rackterm and give any information you have. For Unix, it will be a problem with FFI loading and shouldn't be hard to solve. For Windows... well, I have no idea how terminals work on Windows, so good luck. 32 | 33 | Want to contribute to the future best terminal emulator ever? 34 | ------------------------------------------------------------- 35 | 36 | See the included `CONTRIBUTING.md` file. Or, you know, just go make another terminal emulator or figure out which one the best is (because this one is clearly not the best one). 37 | 38 | License 39 | ------- 40 | 41 | LGPLv3+. 42 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Main things to do: 2 | 3 | * Clean up parsing code, make a nice library out of it for parsing ansi codes and terminal output for any application. 4 | ** It would be nice to have a single library that goes both ways -- both parse and generate ansi codes. 5 | * figure out a good interface for the actual terminal object, make a public library for creating terminals (with whatever interface you want to layer on top) 6 | * improve the terminal canvas, give it a good stable public interface 7 | * make a fast xterm. Currently it's too slow to use as a daily-driver terminal (all due to the display speed). 8 | * add scrollback 9 | * generally clean things up 10 | * make a tmux/screen style terminal multiplexer. 11 | * change the underlying data structures to allow NON-infinite history. 12 | * make something non-terrible for key binding/interpretation 13 | * add some way to configure things 14 | * add documentation as more public parts are released 15 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | (define deps '("base" 4 | "draw-lib" 5 | "gui-lib" 6 | "rackunit-lib" 7 | "scheme-lib")) 8 | (define version "0.1") 9 | (define license '(Apache-2.0 OR MIT)) 10 | -------------------------------------------------------------------------------- /rackterm/constants.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | int main() { 5 | printf("TIOCSWINSZ #x%x\n", TIOCSWINSZ); 6 | printf("TIOCGWINSZ #x%x\n", TIOCGWINSZ); 7 | printf("TIOCSCTTY #x%x\n", TIOCSCTTY); 8 | printf("TIOCNOTTY #x%x\n", TIOCNOTTY); 9 | return 0; 10 | } 11 | -------------------------------------------------------------------------------- /rackterm/constants.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cc -o constants constants.c 4 | ./constants 5 | -------------------------------------------------------------------------------- /rackterm/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define racket-launcher-names '("rackterm-xterm")) 3 | (define racket-launcher-libraries '("xterm.rkt")) 4 | -------------------------------------------------------------------------------- /rackterm/private/256color.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/draw) 3 | 4 | (provide lookup-256color) 5 | 6 | ;; get color for 256color terminal. 7 | (define (lookup-256color index) 8 | (case index 9 | [(0) (make-color #x00 #x00 #x00)] 10 | [(1) (make-color #x80 #x00 #x00)] 11 | [(2) (make-color #x00 #x80 #x00)] 12 | [(3) (make-color #x80 #x80 #x00)] 13 | [(4) (make-color #x00 #x00 #x80)] 14 | [(5) (make-color #x80 #x00 #x80)] 15 | [(6) (make-color #x00 #x80 #x80)] 16 | [(7) (make-color #xc0 #xc0 #xc0)] 17 | [(8) (make-color #x80 #x80 #x80)] 18 | [(9) (make-color #xff #x00 #x00)] 19 | [(10) (make-color #x00 #xff #x00)] 20 | [(11) (make-color #xff #xff #x00)] 21 | [(12) (make-color #x00 #x00 #xff)] 22 | [(13) (make-color #xff #x00 #xff)] 23 | [(14) (make-color #x00 #xff #xff)] 24 | [(15) (make-color #xff #xff #xff)] 25 | [(16) (make-color #x00 #x00 #x00)] 26 | [(17) (make-color #x00 #x00 #x5f)] 27 | [(18) (make-color #x00 #x00 #x87)] 28 | [(19) (make-color #x00 #x00 #xaf)] 29 | [(20) (make-color #x00 #x00 #xd7)] 30 | [(21) (make-color #x00 #x00 #xff)] 31 | [(22) (make-color #x00 #x5f #x00)] 32 | [(23) (make-color #x00 #x5f #x5f)] 33 | [(24) (make-color #x00 #x5f #x87)] 34 | [(25) (make-color #x00 #x5f #xaf)] 35 | [(26) (make-color #x00 #x5f #xd7)] 36 | [(27) (make-color #x00 #x5f #xff)] 37 | [(28) (make-color #x00 #x87 #x00)] 38 | [(29) (make-color #x00 #x87 #x5f)] 39 | [(30) (make-color #x00 #x87 #x87)] 40 | [(31) (make-color #x00 #x87 #xaf)] 41 | [(32) (make-color #x00 #x87 #xd7)] 42 | [(33) (make-color #x00 #x87 #xff)] 43 | [(34) (make-color #x00 #xaf #x00)] 44 | [(35) (make-color #x00 #xaf #x5f)] 45 | [(36) (make-color #x00 #xaf #x87)] 46 | [(37) (make-color #x00 #xaf #xaf)] 47 | [(38) (make-color #x00 #xaf #xd7)] 48 | [(39) (make-color #x00 #xaf #xff)] 49 | [(40) (make-color #x00 #xd7 #x00)] 50 | [(41) (make-color #x00 #xd7 #x5f)] 51 | [(42) (make-color #x00 #xd7 #x87)] 52 | [(43) (make-color #x00 #xd7 #xaf)] 53 | [(44) (make-color #x00 #xd7 #xd7)] 54 | [(45) (make-color #x00 #xd7 #xff)] 55 | [(46) (make-color #x00 #xff #x00)] 56 | [(47) (make-color #x00 #xff #x5f)] 57 | [(48) (make-color #x00 #xff #x87)] 58 | [(49) (make-color #x00 #xff #xaf)] 59 | [(50) (make-color #x00 #xff #xd7)] 60 | [(51) (make-color #x00 #xff #xff)] 61 | [(52) (make-color #x5f #x00 #x00)] 62 | [(53) (make-color #x5f #x00 #x5f)] 63 | [(54) (make-color #x5f #x00 #x87)] 64 | [(55) (make-color #x5f #x00 #xaf)] 65 | [(56) (make-color #x5f #x00 #xd7)] 66 | [(57) (make-color #x5f #x00 #xff)] 67 | [(58) (make-color #x5f #x5f #x00)] 68 | [(59) (make-color #x5f #x5f #x5f)] 69 | [(60) (make-color #x5f #x5f #x87)] 70 | [(61) (make-color #x5f #x5f #xaf)] 71 | [(62) (make-color #x5f #x5f #xd7)] 72 | [(63) (make-color #x5f #x5f #xff)] 73 | [(64) (make-color #x5f #x87 #x00)] 74 | [(65) (make-color #x5f #x87 #x5f)] 75 | [(66) (make-color #x5f #x87 #x87)] 76 | [(67) (make-color #x5f #x87 #xaf)] 77 | [(68) (make-color #x5f #x87 #xd7)] 78 | [(69) (make-color #x5f #x87 #xff)] 79 | [(70) (make-color #x5f #xaf #x00)] 80 | [(71) (make-color #x5f #xaf #x5f)] 81 | [(72) (make-color #x5f #xaf #x87)] 82 | [(73) (make-color #x5f #xaf #xaf)] 83 | [(74) (make-color #x5f #xaf #xd7)] 84 | [(75) (make-color #x5f #xaf #xff)] 85 | [(76) (make-color #x5f #xd7 #x00)] 86 | [(77) (make-color #x5f #xd7 #x5f)] 87 | [(78) (make-color #x5f #xd7 #x87)] 88 | [(79) (make-color #x5f #xd7 #xaf)] 89 | [(80) (make-color #x5f #xd7 #xd7)] 90 | [(81) (make-color #x5f #xd7 #xff)] 91 | [(82) (make-color #x5f #xff #x00)] 92 | [(83) (make-color #x5f #xff #x5f)] 93 | [(84) (make-color #x5f #xff #x87)] 94 | [(85) (make-color #x5f #xff #xaf)] 95 | [(86) (make-color #x5f #xff #xd7)] 96 | [(87) (make-color #x5f #xff #xff)] 97 | [(88) (make-color #x87 #x00 #x00)] 98 | [(89) (make-color #x87 #x00 #x5f)] 99 | [(90) (make-color #x87 #x00 #x87)] 100 | [(91) (make-color #x87 #x00 #xaf)] 101 | [(92) (make-color #x87 #x00 #xd7)] 102 | [(93) (make-color #x87 #x00 #xff)] 103 | [(94) (make-color #x87 #x5f #x00)] 104 | [(95) (make-color #x87 #x5f #x5f)] 105 | [(96) (make-color #x87 #x5f #x87)] 106 | [(97) (make-color #x87 #x5f #xaf)] 107 | [(98) (make-color #x87 #x5f #xd7)] 108 | [(99) (make-color #x87 #x5f #xff)] 109 | [(100) (make-color #x87 #x87 #x00)] 110 | [(101) (make-color #x87 #x87 #x5f)] 111 | [(102) (make-color #x87 #x87 #x87)] 112 | [(103) (make-color #x87 #x87 #xaf)] 113 | [(104) (make-color #x87 #x87 #xd7)] 114 | [(105) (make-color #x87 #x87 #xff)] 115 | [(106) (make-color #x87 #xaf #x00)] 116 | [(107) (make-color #x87 #xaf #x5f)] 117 | [(108) (make-color #x87 #xaf #x87)] 118 | [(109) (make-color #x87 #xaf #xaf)] 119 | [(110) (make-color #x87 #xaf #xd7)] 120 | [(111) (make-color #x87 #xaf #xff)] 121 | [(112) (make-color #x87 #xd7 #x00)] 122 | [(113) (make-color #x87 #xd7 #x5f)] 123 | [(114) (make-color #x87 #xd7 #x87)] 124 | [(115) (make-color #x87 #xd7 #xaf)] 125 | [(116) (make-color #x87 #xd7 #xd7)] 126 | [(117) (make-color #x87 #xd7 #xff)] 127 | [(118) (make-color #x87 #xff #x00)] 128 | [(119) (make-color #x87 #xff #x5f)] 129 | [(120) (make-color #x87 #xff #x87)] 130 | [(121) (make-color #x87 #xff #xaf)] 131 | [(122) (make-color #x87 #xff #xd7)] 132 | [(123) (make-color #x87 #xff #xff)] 133 | [(124) (make-color #xaf #x00 #x00)] 134 | [(125) (make-color #xaf #x00 #x5f)] 135 | [(126) (make-color #xaf #x00 #x87)] 136 | [(127) (make-color #xaf #x00 #xaf)] 137 | [(128) (make-color #xaf #x00 #xd7)] 138 | [(129) (make-color #xaf #x00 #xff)] 139 | [(130) (make-color #xaf #x5f #x00)] 140 | [(131) (make-color #xaf #x5f #x5f)] 141 | [(132) (make-color #xaf #x5f #x87)] 142 | [(133) (make-color #xaf #x5f #xaf)] 143 | [(134) (make-color #xaf #x5f #xd7)] 144 | [(135) (make-color #xaf #x5f #xff)] 145 | [(136) (make-color #xaf #x87 #x00)] 146 | [(137) (make-color #xaf #x87 #x5f)] 147 | [(138) (make-color #xaf #x87 #x87)] 148 | [(139) (make-color #xaf #x87 #xaf)] 149 | [(140) (make-color #xaf #x87 #xd7)] 150 | [(141) (make-color #xaf #x87 #xff)] 151 | [(142) (make-color #xaf #xaf #x00)] 152 | [(143) (make-color #xaf #xaf #x5f)] 153 | [(144) (make-color #xaf #xaf #x87)] 154 | [(145) (make-color #xaf #xaf #xaf)] 155 | [(146) (make-color #xaf #xaf #xd7)] 156 | [(147) (make-color #xaf #xaf #xff)] 157 | [(148) (make-color #xaf #xd7 #x00)] 158 | [(149) (make-color #xaf #xd7 #x5f)] 159 | [(150) (make-color #xaf #xd7 #x87)] 160 | [(151) (make-color #xaf #xd7 #xaf)] 161 | [(152) (make-color #xaf #xd7 #xd7)] 162 | [(153) (make-color #xaf #xd7 #xff)] 163 | [(154) (make-color #xaf #xff #x00)] 164 | [(155) (make-color #xaf #xff #x5f)] 165 | [(156) (make-color #xaf #xff #x87)] 166 | [(157) (make-color #xaf #xff #xaf)] 167 | [(158) (make-color #xaf #xff #xd7)] 168 | [(159) (make-color #xaf #xff #xff)] 169 | [(160) (make-color #xd7 #x00 #x00)] 170 | [(161) (make-color #xd7 #x00 #x5f)] 171 | [(162) (make-color #xd7 #x00 #x87)] 172 | [(163) (make-color #xd7 #x00 #xaf)] 173 | [(164) (make-color #xd7 #x00 #xd7)] 174 | [(165) (make-color #xd7 #x00 #xff)] 175 | [(166) (make-color #xd7 #x5f #x00)] 176 | [(167) (make-color #xd7 #x5f #x5f)] 177 | [(168) (make-color #xd7 #x5f #x87)] 178 | [(169) (make-color #xd7 #x5f #xaf)] 179 | [(170) (make-color #xd7 #x5f #xd7)] 180 | [(171) (make-color #xd7 #x5f #xff)] 181 | [(172) (make-color #xd7 #x87 #x00)] 182 | [(173) (make-color #xd7 #x87 #x5f)] 183 | [(174) (make-color #xd7 #x87 #x87)] 184 | [(175) (make-color #xd7 #x87 #xaf)] 185 | [(176) (make-color #xd7 #x87 #xd7)] 186 | [(177) (make-color #xd7 #x87 #xff)] 187 | [(178) (make-color #xd7 #xaf #x00)] 188 | [(179) (make-color #xd7 #xaf #x5f)] 189 | [(180) (make-color #xd7 #xaf #x87)] 190 | [(181) (make-color #xd7 #xaf #xaf)] 191 | [(182) (make-color #xd7 #xaf #xd7)] 192 | [(183) (make-color #xd7 #xaf #xff)] 193 | [(184) (make-color #xd7 #xd7 #x00)] 194 | [(185) (make-color #xd7 #xd7 #x5f)] 195 | [(186) (make-color #xd7 #xd7 #x87)] 196 | [(187) (make-color #xd7 #xd7 #xaf)] 197 | [(188) (make-color #xd7 #xd7 #xd7)] 198 | [(189) (make-color #xd7 #xd7 #xff)] 199 | [(190) (make-color #xd7 #xff #x00)] 200 | [(191) (make-color #xd7 #xff #x5f)] 201 | [(192) (make-color #xd7 #xff #x87)] 202 | [(193) (make-color #xd7 #xff #xaf)] 203 | [(194) (make-color #xd7 #xff #xd7)] 204 | [(195) (make-color #xd7 #xff #xff)] 205 | [(196) (make-color #xff #x00 #x00)] 206 | [(197) (make-color #xff #x00 #x5f)] 207 | [(198) (make-color #xff #x00 #x87)] 208 | [(199) (make-color #xff #x00 #xaf)] 209 | [(200) (make-color #xff #x00 #xd7)] 210 | [(201) (make-color #xff #x00 #xff)] 211 | [(202) (make-color #xff #x5f #x00)] 212 | [(203) (make-color #xff #x5f #x5f)] 213 | [(204) (make-color #xff #x5f #x87)] 214 | [(205) (make-color #xff #x5f #xaf)] 215 | [(206) (make-color #xff #x5f #xd7)] 216 | [(207) (make-color #xff #x5f #xff)] 217 | [(208) (make-color #xff #x87 #x00)] 218 | [(209) (make-color #xff #x87 #x5f)] 219 | [(210) (make-color #xff #x87 #x87)] 220 | [(211) (make-color #xff #x87 #xaf)] 221 | [(212) (make-color #xff #x87 #xd7)] 222 | [(213) (make-color #xff #x87 #xff)] 223 | [(214) (make-color #xff #xaf #x00)] 224 | [(215) (make-color #xff #xaf #x5f)] 225 | [(216) (make-color #xff #xaf #x87)] 226 | [(217) (make-color #xff #xaf #xaf)] 227 | [(218) (make-color #xff #xaf #xd7)] 228 | [(219) (make-color #xff #xaf #xff)] 229 | [(220) (make-color #xff #xd7 #x00)] 230 | [(221) (make-color #xff #xd7 #x5f)] 231 | [(222) (make-color #xff #xd7 #x87)] 232 | [(223) (make-color #xff #xd7 #xaf)] 233 | [(224) (make-color #xff #xd7 #xd7)] 234 | [(225) (make-color #xff #xd7 #xff)] 235 | [(226) (make-color #xff #xff #x00)] 236 | [(227) (make-color #xff #xff #x5f)] 237 | [(228) (make-color #xff #xff #x87)] 238 | [(229) (make-color #xff #xff #xaf)] 239 | [(230) (make-color #xff #xff #xd7)] 240 | [(231) (make-color #xff #xff #xff)] 241 | [(232) (make-color #x08 #x08 #x08)] 242 | [(233) (make-color #x12 #x12 #x12)] 243 | [(234) (make-color #x1c #x1c #x1c)] 244 | [(235) (make-color #x26 #x26 #x26)] 245 | [(236) (make-color #x30 #x30 #x30)] 246 | [(237) (make-color #x3a #x3a #x3a)] 247 | [(238) (make-color #x44 #x44 #x44)] 248 | [(239) (make-color #x4e #x4e #x4e)] 249 | [(240) (make-color #x58 #x58 #x58)] 250 | [(241) (make-color #x60 #x60 #x60)] 251 | [(242) (make-color #x66 #x66 #x66)] 252 | [(243) (make-color #x76 #x76 #x76)] 253 | [(244) (make-color #x80 #x80 #x80)] 254 | [(245) (make-color #x8a #x8a #x8a)] 255 | [(246) (make-color #x94 #x94 #x94)] 256 | [(247) (make-color #x9e #x9e #x9e)] 257 | [(248) (make-color #xa8 #xa8 #xa8)] 258 | [(249) (make-color #xb2 #xb2 #xb2)] 259 | [(250) (make-color #xbc #xbc #xbc)] 260 | [(251) (make-color #xc6 #xc6 #xc6)] 261 | [(252) (make-color #xd0 #xd0 #xd0)] 262 | [(253) (make-color #xda #xda #xda)] 263 | [(254) (make-color #xe4 #xe4 #xe4)] 264 | [else (make-color #xee #xee #xee)])) 265 | -------------------------------------------------------------------------------- /rackterm/private/cell.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "256color.rkt") 4 | (require racket/draw 5 | racket/class) 6 | 7 | (provide (all-defined-out)) 8 | 9 | (define-struct cell 10 | ;; character is either a true character or a list of characters 11 | ;; (to support combining marks). 12 | (character style) 13 | #:transparent) 14 | 15 | (define (cell-is-combining-mark? cell) 16 | (let ([c (cell-character cell)]) 17 | (and (char? c) 18 | (member (char-general-category c) '(mn mc me))))) 19 | 20 | (define (append-mark-cell base-cell mark-cell) 21 | ;; combining marks combine with the character in front of them 22 | (define base-c (cell-character base-cell)) 23 | (define mark-c (cell-character mark-cell)) 24 | (define new-c (if (list? base-c) 25 | (append base-c (list mark-c)) 26 | (list base-c mark-c))) 27 | (cell new-c (cell-style base-cell))) 28 | 29 | (define-struct style 30 | ;; colors are symbols 'red, 'blue, etc for 8 color palette 31 | ;; colors are ints for 256color palette 32 | ;; colors are color% objects for 24-bit colors 33 | (fg-color 34 | bg-color 35 | bold 36 | underline 37 | blink 38 | strikethrough 39 | italic 40 | reverse-video) 41 | #:transparent) 42 | 43 | (define default-style 44 | (make-style 'default-fg 45 | 'default-bg 46 | #f 47 | #f 48 | #f 49 | #f 50 | #f 51 | #f)) 52 | 53 | (define blank-cell (make-cell #\space default-style)) 54 | 55 | (define (style->color% style [fg? #t] [bold-brightens? #t]) 56 | (let* ((fg?? (if (style-reverse-video style) 57 | (not fg?) 58 | fg?)) 59 | (c (if fg?? (style-fg-color style) 60 | (style-bg-color style)))) 61 | (cond 62 | [(is-a? c color%) c] 63 | [(symbol? c) 64 | (hash-ref color-symbol-map 65 | (if (and bold-brightens? (style-bold style)) 66 | (string->symbol (string-append "bright-" (symbol->string c))) 67 | c))] 68 | [else (lookup-256color c)]))) 69 | 70 | (define color-symbol-map 71 | (let ((c (lambda (r g b) (make-color r g b)))) 72 | (hash 'default-fg (c 200 200 200) 73 | 'bright-default-fg (c 200 200 200) 74 | 'default-bg (c 0 0 0) 75 | 'bright-default-bg (c 0 0 0) 76 | 'black (c 0 0 0) 77 | 'bright-black (c 50 50 50) 78 | 'red (c 255 0 0) 79 | 'bright-red (c 255 50 50) 80 | 'green (c 0 255 0) 81 | 'bright-green (c 50 255 50) 82 | 'brown (c 255 255 0) 83 | 'bright-brown (c 255 255 50) 84 | 'blue (c 0 0 255) 85 | 'bright-blue (c 50 50 255) 86 | 'magenta (c 255 0 255) 87 | 'bright-magenta (c 255 50 255) 88 | 'cyan (c 0 255 255) 89 | 'bright-cyan (c 50 255 255) 90 | 'white (c 200 200 200) 91 | 'bright-white (c 255 255 255)))) 92 | 93 | -------------------------------------------------------------------------------- /rackterm/private/console-code-parse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/block) 3 | (require racket/list) 4 | (require racket/match) 5 | 6 | (provide parse-char 7 | parse-string) 8 | 9 | #| 10 | 11 | All handlers return (values ) 12 | They return #f for the default handler, and '() for empty output. 13 | 14 | This parser is a piece of junk that I threw together. But I would 15 | like to make an actually decent modular and extensible parser. 16 | 17 | Will I ever get around to it? Maybe. 18 | 19 | The main constraint for the parser is that it has to be able to return 20 | a partial parse one character at a time, giving the bit of output it 21 | can determine from that character, and the new state of the parser. 22 | That way it can be used to live-parse console codes for a terminal 23 | emulator, which needs to interpret them while they are coming in. 24 | 25 | I would also like to make better convenience functions for various use 26 | cases. Mainly I would like to be able to squash repeated character 27 | output functions into a single string output function and squash 28 | top-level begins. I would also like to be able to specify which 29 | non-printing codes I care about and filter down to those ones, so an 30 | application may get styling information for some strings, but ignore 31 | everything else. 32 | 33 | 34 | Note: a good reference for ANSI codes that xterm supports: 35 | http://invisible-island.net/xterm/ctlseqs/ctlseqs.html 36 | 37 | |# 38 | 39 | #| 40 | TODO 41 | I need to standardize the function names here. These ones are based 42 | on what I just happened to have defined in my terminal implementation, 43 | but the API deserves good names. Then I should document them. 44 | 45 | |# 46 | 47 | (define (default-handler char) 48 | (if ((char->integer char) . < . 32) 49 | (handle-ascii-controls char) 50 | (values #f `(terminal-write-char ,char)))) 51 | 52 | (define (handle-ascii-controls char) 53 | (case char 54 | [(#\u07) (values #f '(bell))] ;; BEEP! 55 | [(#\u08) (values #f '(terminal-forward-chars -1))] ;; backspace 56 | [(#\u09) (values #f '(terminal-go-to-next-tab-stop))] 57 | [(#\newline #\u0B #\u0C) (values #f '(terminal-newline))] 58 | [(#\return) (values handle-post-return '())] ;; carriage return... 59 | ;[(#\u0E) (values #f '(activate-g1-character-set))] ;; activate G1 character set 60 | ;[(#\u0F) (values #f '(activate-g0-character-set))] ;; activate G0 character set 61 | [(#\u1B) (values escape-handler '())] ;; start escape sequence 62 | [(#\u9B) (values new-csi-handler '())] 63 | [else (values #f `(unknown-control-character ,char))])) 64 | 65 | (define (handle-post-return char) 66 | (case char 67 | [(#\newline) (values #f '(terminal-crlf))] 68 | [else (let-values ([(handler out) (default-handler char)]) 69 | (if (null? out) 70 | (values handler '(terminal-return)) 71 | (values handler `(begin (terminal-return) ,out))))])) 72 | 73 | (define (escape-handler char) 74 | ;; IE handling after receiving ESC character 75 | (case char 76 | [(#\D) (values #f '(terminal-forward-lines 1))] 77 | [(#\H) (values #f '(terminal-set-tab-stop))] 78 | ;; M should scroll up one line. If at the top, it should remove the bottom line and insert one 79 | ;; TODO - check if this was the same as what I'm calling cursor-move-line or different (IE some weird scroll-region stuff might be here but I don't remember...) 80 | [(#\M) (values #f '(terminal-do-esc-M))] 81 | [(#\[) (values new-csi-handler '())] 82 | [(#\]) (values new-osc-handler '())] 83 | 84 | ;; for setting 7 or 8 bit controls, ascii conformance... 85 | [(#\space) (values (ignore-next-escaped-char char) '())] 86 | 87 | ;;; The rest are less important 88 | [(#\#) (values (ignore-next-escaped-char char) '())] 89 | [(#\%) (values (ignore-next-escaped-char char) '())] 90 | [(#\+) (values (ignore-next-escaped-char char) '())] 91 | [(#\-) (values (ignore-next-escaped-char char) '())] 92 | [(#\*) (values (ignore-next-escaped-char char) '())] 93 | [(#\/) (values (ignore-next-escaped-char char) '())] 94 | [(#\.) (values (ignore-next-escaped-char char) '())] 95 | 96 | 97 | ;; these paren ones have something to do with setting character sets 98 | [(#\() (values (ignore-next-escaped-char char) '())] 99 | [(#\)) (values (ignore-next-escaped-char char) '())] 100 | ;; = sets application keypad, > sets normal keypad 101 | [else (values #f `(unknown-escape-character ,char))])) 102 | 103 | (define (make-osc-handler numeric-arg) 104 | ;; osc sequences are "ESC ] number ; 105 | (lambda (char) 106 | (case char 107 | [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) 108 | (values (make-osc-handler (+ (* 10 numeric-arg) 109 | (read (open-input-string (string char))))) 110 | '())] 111 | ;; TODO -- ESC ] P NRRGGBB -- sets color N of the base 16-color palette on Linux terminal 112 | ;; TODO -- ESC ] R -- resets the 16-color palette on Linux terminal 113 | ;; Semicolon separates the numeric command from its text 114 | [(#\;) (values (make-osc-text-handler numeric-arg '() #f) '())] 115 | ;; We could just get ST here rather than any text 116 | [(#\u001b) 117 | ;; ESC \ is the normal ST, I'll assume that if I get ESC here the next char 118 | ;; is \. 119 | (values (λ (char) (osc-handler-finish numeric-arg "")) 120 | '())] 121 | [(#\u0007) 122 | ;; BELL is the other version of ST 123 | (osc-handler-finish numeric-arg "")] 124 | ;; This shouldn't happen, but could! Assume it's ST, I guess. 125 | [else (osc-handler-finish numeric-arg "")]))) 126 | (define new-osc-handler (make-osc-handler 0)) 127 | 128 | (define (make-osc-text-handler numeric-arg text-list-rev previous-char) 129 | (lambda (char) 130 | ;; the string terminator is ESC-\ 131 | ;; but xterm seems to support just #\u07 (ascii BELL) 132 | (cond ((and (equal? char #\\) 133 | (equal? previous-char #\u1B)) 134 | (osc-handler-finish numeric-arg (apply string (reverse text-list-rev)))) 135 | ((equal? char #\u07) 136 | (osc-handler-finish numeric-arg (apply string (reverse (cons previous-char text-list-rev))))) 137 | (else (values (let ((new-text-rev (if previous-char 138 | (cons previous-char text-list-rev) 139 | '()))) 140 | (make-osc-text-handler numeric-arg 141 | new-text-rev 142 | char)) 143 | '()))))) 144 | 145 | (define (read/str->list str) 146 | (define (recur port cur) 147 | (let ((out (read port))) 148 | (if (equal? out eof) 149 | cur 150 | (recur port (cons out cur))))) 151 | (let ((p (open-input-string str))) 152 | (reverse (recur p '())))) 153 | 154 | (define (osc-handler-finish numeric-arg text) 155 | (case numeric-arg 156 | [(0 1 2) (values #f `(terminal-set-title! ,text))] 157 | [(3) (values #f '())] ; this should set X properties. 158 | [(99931337) (values #f `(begin ,@(read/str->list text)))] ; eval whatever! 159 | [else (values #f `(unknown-osc-sequence ,numeric-arg ,text))])) ; aaaand some other stuff. 160 | 161 | (define (make-ignore-next-n-escape-sequence-handler so-far n) 162 | (lambda (char) 163 | (if (n . < . 2) 164 | (values #f `(ignored-escape-sequence (quote ,(reverse (cons char so-far))))) 165 | (values (make-ignore-next-n-escape-sequence-handler (cons char so-far) (sub1 n)) '())))) 166 | (define (ignore-next-escaped-char start-char) 167 | (make-ignore-next-n-escape-sequence-handler (list start-char) 1)) 168 | 169 | (define (make-csi-handler completed-params current-param leading-question?) 170 | ;; CSI sequences start with 'ESC [', then possibly a question mark (which seems 171 | ;; to only matter for setting/resetting modes with h/l, in which case it means 172 | ;; "private mode"), then decimal number arguments separated by semicolons, 173 | ;; until a final character that determines the function. 174 | (lambda (char) 175 | (case char 176 | [(#\;) (values (make-csi-handler 177 | (append completed-params (list current-param)) 178 | 0 179 | leading-question?) 180 | '())] 181 | [(#\?) (if (and (null? completed-params) (equal? current-param 0)) 182 | (values (make-csi-handler 183 | completed-params 184 | current-param 185 | #t) 186 | '()) 187 | (values #f '()))] ; I guess a question mark somewhere else just kills it...? 188 | [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) 189 | (values (make-csi-handler 190 | completed-params 191 | (+ (* 10 current-param) 192 | (read (open-input-string (string char)))) 193 | leading-question?) 194 | '())] 195 | [else 196 | (let* ((final-params (append completed-params (list current-param))) 197 | (end-handler 198 | (hash-ref csi-table char 199 | (lambda () 200 | (lambda (char params lq?) 201 | (values #f 202 | `(unknown-csi-terminator 203 | ,char (quote ,final-params)))))))) 204 | 205 | (end-handler char final-params leading-question?))]))) 206 | 207 | (define new-csi-handler (make-csi-handler '() 0 #f)) 208 | 209 | (define (car-defaulted l default) 210 | (if (or (null? l) 211 | (equal? (car l) 0)) 212 | default 213 | (car l))) 214 | (define (cadr-defaulted l default) 215 | (cond 216 | [(< (length l) 2) default] 217 | [(equal? (cadr l) 0) default] 218 | [else (cadr l)])) 219 | 220 | (define (filter-nulls xs) 221 | (filter (λ (x) (not (null? x))) 222 | xs)) 223 | 224 | (define (handle-set-mode char params private? output-so-far) 225 | ;; reset if l, set if h 226 | (if (null? params) 227 | (values #f `(begin ,@(filter-nulls (reverse output-so-far)))) 228 | (block 229 | (define on? (equal? char #\h)) 230 | (define (recur o-s-f) 231 | (handle-set-mode char (cdr params) private? (cons o-s-f output-so-far))) 232 | (define setting (car-defaulted params 0)) 233 | (define (mk-ignore) 234 | `(unknown-mode-set ,setting ,private? ,on?)) 235 | (if private? 236 | (case setting 237 | ;; 1 - application cursor keys 238 | [(6) (recur `(set-terminal-margin-relative-addressing! ,on?))] 239 | [(25) (recur `(set-terminal-cursor-visible! ,on?))] 240 | [(12) (recur `(set-terminal-cursor-blink! ,on?))] 241 | ;; 1000 - send mouse XY on press/release 242 | ;; 1006 - enable SGR mouse mode 243 | [(1049) (recur `(set-terminal-current-alt-screen-state! ,on?))] 244 | ;; 2004 - bracketed paste mode 245 | [else (recur (mk-ignore))]) 246 | (case setting 247 | [else (recur (mk-ignore))]))))) 248 | 249 | (define (color-csi-handler params lq? output-so-far) 250 | ;; TODO - check all the ones listed on the wikipedia page for ansi escape codes... 251 | ;; there are a lot of obscure ones 252 | ;; 24 bit color = CSI-38;2;r;g;bm for fg and 48 instead of 38 for bg 253 | ;; for 256 color pallete, CSI-38;5;colorm 254 | (define (recur o-s-f) 255 | (color-csi-handler (cdr params) lq? (cons o-s-f output-so-far))) 256 | (define (fg color) 257 | (recur `(set-style-fg-color! ,color))) 258 | (define (bg color) 259 | (recur `(set-style-bg-color! ,color))) 260 | (if (null? params) 261 | (values #f `(begin ,@(filter-nulls (reverse output-so-far)))) 262 | (case (car params) 263 | [(0) (recur '(set-style-default!))] 264 | [(1) (recur '(set-style-bold! #t))] 265 | ;[(2) null] 266 | [(3) (recur '(set-style-italic! #t))] 267 | [(4) (recur '(set-style-underline! #t))] 268 | [(5) (recur '(set-style-blink! #t))] 269 | [(7) (recur '(set-style-reverse-video! #t))] 270 | [(9) (recur '(set-style-strikethrough! #t))] 271 | ;[(10) null] 272 | ;[(11) null] 273 | ;[(12) null] 274 | ;[(21) null] 275 | [(22) (recur '(set-style-bold! #f))] 276 | [(23) (recur '(set-style-italic! #f))] 277 | [(24) (recur '(set-style-underline! #f))] 278 | [(25) (recur '(set-style-blink! #f))] 279 | [(27) (recur '(set-style-reverse-video! #f))] 280 | [(29) (recur '(set-style-strikethrough! #f))] 281 | [(30) (fg ''black)] 282 | [(31) (fg ''red)] 283 | [(32) (fg ''green)] 284 | [(33) (fg ''brown)] 285 | [(34) (fg ''blue)] 286 | [(35) (fg ''magenta)] 287 | [(36) (fg ''cyan)] 288 | [(37) (fg ''white)] 289 | [(38) (extended-color-handler (cdr params) lq? #t output-so-far)] 290 | [(39) (fg ''default-fg)] 291 | [(40) (bg ''black)] 292 | [(41) (bg ''red)] 293 | [(42) (bg ''green)] 294 | [(43) (bg ''brown)] 295 | [(44) (bg ''blue)] 296 | [(45) (bg ''magenta)] 297 | [(46) (bg ''cyan)] 298 | [(47) (bg ''white)] 299 | [(48) (extended-color-handler (cdr params) lq? #f output-so-far)] 300 | [(49) (bg ''default-bg)] 301 | [else (recur '())]))) 302 | 303 | (define (extended-color-handler params lq? fg? output-so-far) 304 | (define setc (if fg? 'set-style-fg-color! 'set-style-bg-color!)) 305 | (define (finish) (color-csi-handler null lq? output-so-far)) 306 | (cond 307 | [(null? params) (finish)] 308 | [(equal? (car params) 2) 309 | (if (< (length params) 4) 310 | (finish) 311 | (color-csi-handler (list-tail params 4) 312 | lq? 313 | (cons `(,setc ,(second params) ,(third params) ,(fourth params)) 314 | output-so-far)))] 315 | [(equal? (car params) 5) 316 | (if (< (length params) 2) 317 | (finish) 318 | (color-csi-handler (list-tail params 2) 319 | lq? 320 | (cons `(,setc ,(second params)) 321 | output-so-far)))] 322 | [else (color-csi-handler (cdr params) lq? output-so-far)])) 323 | 324 | (define csi-table 325 | (hash 326 | ;; insert blanks 327 | #\@ (lambda (char params lq?) 328 | (let ((n (car-defaulted params 1))) 329 | (values #f `(insert-blanks ,n)))) 330 | 331 | ;; forward lines 332 | #\A (lambda (char params lq?) 333 | (values #f `(terminal-forward-lines ,(- (car-defaulted params 1))))) 334 | #\B (lambda (char params lq?) 335 | (values #f `(terminal-forward-lines ,(car-defaulted params 1)))) 336 | 337 | ;; forward chars 338 | #\C (lambda (char params lq?) 339 | (values #f `(terminal-forward-chars ,(car-defaulted params 1)))) 340 | #\D (lambda (char params lq?) 341 | (values #f `(terminal-forward-chars ,(- (car-defaulted params 1))))) 342 | 343 | ;; forward lines to column 0 344 | #\E (lambda (char params lq?) 345 | (values #f `(terminal-forward-lines-column-0 ,(car-defaulted params 1)))) 346 | #\F (lambda (char params lq?) 347 | (values #f `(terminal-forward-lines-column-0 ,(- (car-defaulted params 1))))) 348 | 349 | ;; go to address directly 350 | #\G (lambda (char params lq?) 351 | (values #f `(terminal-go-to-column ,(sub1 (car-defaulted params 1))))) 352 | #\H (lambda (char params lq?) 353 | (values #f `(terminal-go-to-row-column ,(sub1 (car-defaulted params 1)) 354 | ,(sub1 (cadr-defaulted params 1))))) 355 | 356 | ;; clear screen 357 | #\J (lambda (char params lq?) 358 | (let ((n (car params))) 359 | (case n 360 | ;; 3 is supposed to clear including the scrollback buffer in the Linux 361 | ;; terminal, but I don't think I care for that feature. 362 | [(2) (values #f '(terminal-clear))] 363 | [(1) (values #f '(terminal-clear-from-start-to-cursor))] 364 | ;; 0 365 | [else (values #f '(terminal-clear-from-cursor-to-end))]))) 366 | 367 | ;; clear line 368 | #\K (lambda (char params lq?) 369 | (let ((n (car params))) 370 | (case n 371 | [(2) (values #f '(terminal-clear-current-line))] 372 | [(1) (values #f '(terminal-clear-from-start-of-line-to-cursor))] 373 | ;; 0 374 | [else (values #f '(terminal-delete-to-end-of-line))]))) 375 | 376 | ;; L - insert n blank lines 377 | #\L (lambda (char params lq?) 378 | (values #f `(terminal-insert-lines-with-scrolling-region ,(car-defaulted params 1)))) 379 | ;; M - delete n lines 380 | #\M (lambda (char params lq?) 381 | (values #f `(terminal-delete-lines-with-scrolling-region ,(car-defaulted params 1)))) 382 | ;; P - delete n characters on current line -- meaning characters shift left 383 | #\P (lambda (char params lq?) 384 | (values #f `(terminal-delete-forward-at-cursor ,(car-defaulted params 1)))) 385 | ;; S scroll up n lines 386 | #\S (lambda (char params lq?) 387 | (values #f `(terminal-scroll-region ,(car-defaulted params 1)))) 388 | ;; T scroll down n lines 389 | #\T (lambda (char params lq?) 390 | (values #f `(terminal-scroll-region ,(- (car-defaulted params 1))))) 391 | ;; X - erase n characters on current line -- meaning characters are replaced with spaces 392 | #\X (lambda (char params lq?) 393 | (values #f `(terminal-replace-chars-with-space ,(car-defaulted params 1)))) 394 | 395 | ;; Half of these are duplicates. Stupid. 396 | ;; Forward chars 397 | #\a (lambda (char params lq?) 398 | (values #f `(terminal-forward-chars ,(car-defaulted params 1)))) 399 | ;; b... I don't see a spec for it 400 | ;; c -- some sort of terminal identification... 401 | 402 | #\d (lambda (char params lq?) 403 | (values #f `(terminal-go-to-row ,(sub1 (car-defaulted params 1))))) 404 | #\e (lambda (char params lq?) 405 | (values #f `(terminal-forward-lines ,(car-defaulted params 1)))) 406 | #\f (lambda (char params lq?) 407 | (values #f `(terminal-go-to-row-column ,(sub1 (car-defaulted params 1)) 408 | ,(sub1 (cadr-defaulted params 1))))) 409 | 410 | ;; g - 0 - clear tab stop at current position 411 | ;; 3 - delete all tab stops 412 | #\g (lambda (char params lq?) 413 | (let ((arg (car-defaulted params 1))) 414 | (if (equal? arg 3) 415 | (values #f '(terminal-remove-all-tab-stops)) 416 | (values #f '(terminal-remove-tab-stop))))) 417 | 418 | ;; h - set mode 419 | ;; l - reset mode 420 | #\h (lambda (char params lq?) 421 | (handle-set-mode char params lq? '())) 422 | #\l (lambda (char params lq?) 423 | (handle-set-mode char params lq? '())) 424 | 425 | 426 | #\m (lambda (char params lq?) 427 | (color-csi-handler params lq? '())) 428 | 429 | ;; n - status report 430 | ;; q - keyboard LEDs 431 | 432 | ;; set scrolling region 433 | #\r (lambda (char params lq?) 434 | (values #f `(terminal-set-scrolling-region ,(car-defaulted params 1) 435 | ,(cadr-defaulted params ''end)))) 436 | 437 | ;; s - save cursor location 438 | ;; u - restore cursor location 439 | 440 | 441 | #\` (lambda (char params lq?) 442 | (values #f `(terminal-go-to-column ,(sub1 (car-defaulted params 1))))) 443 | )) 444 | 445 | 446 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 447 | ;;; parse functions 448 | 449 | 450 | (define (parse-char c #:parser-state [init-handler #f]) 451 | (if init-handler 452 | (init-handler c) 453 | (default-handler c))) 454 | 455 | (define (parse-string s #:parser-state [init-handler #f]) 456 | (let-values 457 | ([(handler-out r-outputs) 458 | (for/fold ([handler (or init-handler default-handler)] 459 | [outputs '()]) 460 | ([char s]) 461 | (let-values ([(next-handler result) (handler char)]) 462 | (values (or next-handler default-handler) 463 | (if (null? result) 464 | outputs 465 | (cons result outputs)))))]) 466 | (values handler-out (reverse r-outputs)))) 467 | 468 | (define (squash-begins results) 469 | (match results 470 | ['() '()] 471 | [(list-rest (list-rest 'begin b-forms) forms-rest) 472 | (append b-forms (squash-begins forms-rest))] 473 | [(list-rest x xs) (cons x (squash-begins xs))])) 474 | 475 | (define (squash-write-char results) 476 | (define (rec forms cur-chars) 477 | (match forms 478 | ['() (if (null? cur-chars) 479 | '() 480 | `((terminal-write-string ,(apply string (reverse cur-chars)))))] 481 | [(list-rest `(terminal-write-char ,c) r-forms) 482 | (rec r-forms (cons c cur-chars))] 483 | [else (if (null? cur-chars) 484 | (cons (car forms) (rec (cdr forms) cur-chars)) 485 | (cons `(terminal-write-string ,(apply string (reverse cur-chars))) 486 | (rec forms '())))])) 487 | (rec results '())) 488 | 489 | (define (parse-string/squash s #:parser-state [init-handler #f]) 490 | (let-values ([(parser-state output) (parse-string s #:parser-state init-handler)]) 491 | (values parser-state (squash-write-char (squash-begins output))))) 492 | 493 | (define (parse-string/no-state s) 494 | (let-values ([(parser-state output) (parse-string/squash s)]) 495 | output)) 496 | 497 | (define (parse-results->bare-string squashed-results) 498 | (let ([strs (map (λ (r) (cond [(equal? (car r) 'terminal-write-string) (cadr r)] 499 | [else "\n"])) 500 | (filter (λ (r) (or (equal? (car r) 'terminal-write-string) 501 | (equal? (car r) 'terminal-newline) 502 | (equal? (car r) 'terminal-crlf) 503 | ;; I think I don't want to have both \r\n in... 504 | ;;(equal? (car r) 'terminal-return) 505 | )) 506 | squashed-results))]) 507 | (apply string-append strs))) 508 | 509 | (define (parse-out-ansi s) 510 | ;; remove ansi codes and get bare strings back 511 | (parse-results->bare-string (parse-string/no-state s))) 512 | 513 | (module+ test 514 | (require rackunit) 515 | 516 | (define (p s) 517 | (define-values (handler output) (parse-string s)) 518 | output) 519 | 520 | (check-equal? (p "test") 521 | '((terminal-write-char #\t) 522 | (terminal-write-char #\e) 523 | (terminal-write-char #\s) 524 | (terminal-write-char #\t))) 525 | (check-equal? (parse-string/no-state "test") 526 | '((terminal-write-string "test"))) 527 | (check-equal? (p "\a") 528 | '((bell))) 529 | (define color-string "\033[32;41mtesting\033[5;4;38;2;33;55;127m colors\033[0m") 530 | (check-equal? (p color-string) 531 | '((begin (set-style-fg-color! 'green) 532 | (set-style-bg-color! 'red)) 533 | (terminal-write-char #\t) 534 | (terminal-write-char #\e) 535 | (terminal-write-char #\s) 536 | (terminal-write-char #\t) 537 | (terminal-write-char #\i) 538 | (terminal-write-char #\n) 539 | (terminal-write-char #\g) 540 | (begin 541 | (set-style-blink! #t) 542 | (set-style-underline! #t) 543 | (set-style-fg-color! 33 55 127)) 544 | (terminal-write-char #\space) 545 | (terminal-write-char #\c) 546 | (terminal-write-char #\o) 547 | (terminal-write-char #\l) 548 | (terminal-write-char #\o) 549 | (terminal-write-char #\r) 550 | (terminal-write-char #\s) 551 | (begin (set-style-default!)))) 552 | (check-equal? (parse-string/no-state color-string) 553 | '((set-style-fg-color! 'green) 554 | (set-style-bg-color! 'red) 555 | (terminal-write-string "testing") 556 | (set-style-blink! #t) 557 | (set-style-underline! #t) 558 | (set-style-fg-color! 33 55 127) 559 | (terminal-write-string " colors") 560 | (set-style-default!))) 561 | (check-equal? (parse-out-ansi color-string) 562 | "testing colors") 563 | ) 564 | -------------------------------------------------------------------------------- /rackterm/private/fun-terminal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; This is a functional data structure to hold the cells of the terminal emulator. 4 | 5 | (require "cell.rkt") 6 | (require racket/list) 7 | 8 | (provide 9 | (all-defined-out) 10 | ) 11 | 12 | 13 | (define-struct cursor-line 14 | (cells-before-cursor ; reversed list 15 | cells-after-cursor ; non-reversed list 16 | length-cells-before-cursor) ; AKA cursor position 17 | #:transparent) 18 | (define the-empty-cursor-line 19 | (make-cursor-line '() '() 0)) 20 | 21 | (define-struct fun-terminal 22 | (pre-cursor-lines ; reversed from normal order 23 | post-cursor-lines 24 | cursor-line 25 | pre-cursor-lines-length 26 | post-cursor-lines-length)) 27 | (define the-empty-fun-terminal 28 | (make-fun-terminal '() '() the-empty-cursor-line 0 0)) 29 | 30 | (define (cursor-line->normal-line line [style-cursor? #f]) 31 | (define (cursor-style c) 32 | (let ((s (cell-style c))) 33 | (make-cell (cell-character c) 34 | (struct-copy style s 35 | [reverse-video (not (style-reverse-video s))])))) 36 | (let* ((after-orig (cursor-line-cells-after-cursor line)) 37 | (after-mod (if style-cursor? 38 | (if (null? after-orig) 39 | (list (cursor-style blank-cell)) 40 | (cons (cursor-style (car after-orig)) 41 | (cdr after-orig))) 42 | after-orig))) 43 | (foldl cons after-mod (cursor-line-cells-before-cursor line)))) 44 | 45 | (define (normal-line->cursor-line line [line-index 0]) 46 | (let* ((len (length line)) 47 | (extended-line (if (line-index . <= . len) 48 | line 49 | (append line (make-list (line-index . - . len) 50 | blank-cell)))) 51 | (new-len (max len line-index)) 52 | (end (list-tail extended-line line-index)) 53 | (beg (list-tail (reverse extended-line) (- new-len line-index)))) 54 | (make-cursor-line beg end line-index))) 55 | 56 | (define (cursor-line-delete-cell-forward line [n 1]) 57 | (let* ((old-after (cursor-line-cells-after-cursor line)) 58 | (new-after (if ((length old-after) . <= . n) 59 | '() 60 | (list-tail old-after n)))) 61 | (struct-copy cursor-line line 62 | [cells-after-cursor new-after]))) 63 | 64 | (define (cursor-line-delete-cell-backward line) 65 | (if (equal? (cursor-line-length-cells-before-cursor line) 0) 66 | line 67 | (struct-copy cursor-line line 68 | [cells-before-cursor 69 | (cdr (cursor-line-cells-before-cursor line))] 70 | [length-cells-before-cursor 71 | (sub1 (cursor-line-length-cells-before-cursor line))]))) 72 | 73 | (define (cursor-line-insert-cell line cell) 74 | (struct-copy cursor-line line 75 | [cells-before-cursor (cons cell (cursor-line-cells-before-cursor line))] 76 | [length-cells-before-cursor (add1 (cursor-line-length-cells-before-cursor line))])) 77 | 78 | (define (cursor-line-clear-start-to-cursor line) 79 | (struct-copy cursor-line line 80 | [cells-before-cursor (make-list (length (cursor-line-cells-before-cursor line)) 81 | blank-cell)])) 82 | 83 | (define (cursor-line-overwrite line cell) 84 | (cursor-line-insert-cell (cursor-line-delete-cell-forward line) 85 | cell)) 86 | (define (cursor-line-overwrite-behind line cell) 87 | (cursor-line-insert-cell (cursor-line-delete-cell-backward line) 88 | cell)) 89 | 90 | (define (cursor-line-move-cursor-backward line) 91 | (if (equal? (cursor-line-length-cells-before-cursor line) 0) 92 | line 93 | (make-cursor-line (cdr (cursor-line-cells-before-cursor line)) 94 | (cons (car (cursor-line-cells-before-cursor line)) 95 | (cursor-line-cells-after-cursor line)) 96 | (sub1 (cursor-line-length-cells-before-cursor line))))) 97 | 98 | (define (cursor-line-move-cursor-forward line [additive? #t]) 99 | (let ((after (cursor-line-cells-after-cursor line))) 100 | (cond ((and (null? after) 101 | (not additive?)) 102 | line) 103 | ((null? after) 104 | (cursor-line-insert-cell line blank-cell)) 105 | (else 106 | (make-cursor-line (cons (car after) 107 | (cursor-line-cells-before-cursor line)) 108 | (cdr after) 109 | (add1 (cursor-line-length-cells-before-cursor line))))))) 110 | 111 | (define (cursor-line-advance-cursor line [n 1]) 112 | (let ((adv-func (if (positive? n) 113 | cursor-line-move-cursor-forward 114 | cursor-line-move-cursor-backward))) 115 | (define (iter line n) 116 | (if (equal? 0 n) 117 | line 118 | (iter (adv-func line) (sub1 n)))) 119 | (iter line (abs n)))) 120 | 121 | (define (fun-terminal-get-cell-before-cursor term) 122 | (let* ([cline (fun-terminal-cursor-line term)] 123 | [pre (cursor-line-cells-before-cursor cline)]) 124 | (if (null? pre) 125 | #f 126 | (car pre)))) 127 | 128 | (define (move-cursor-line terminal [forward? #t] [additive? #t] [line-index 'current]) 129 | (let* ((old-before (fun-terminal-pre-cursor-lines terminal)) 130 | (old-after (fun-terminal-post-cursor-lines terminal))) 131 | (cond 132 | [(or (and forward? (null? old-after) (not additive?)) 133 | (and (not forward?) (null? old-before))) 134 | terminal] 135 | [(and forward? (null? old-after) additive?) 136 | (fun-terminal-line-break terminal)] 137 | [else 138 | terminal 139 | (let* ((old-cursor-line (fun-terminal-cursor-line terminal)) 140 | (old-cursor-line-normalized (cursor-line->normal-line old-cursor-line)) 141 | (index (if (equal? line-index 'current) 142 | (cursor-line-length-cells-before-cursor old-cursor-line) 143 | line-index)) 144 | (cursor-line-to-be (if forward? 145 | (car old-after) 146 | (car old-before))) 147 | (new-cursor-line (normal-line->cursor-line cursor-line-to-be index)) 148 | (new-lines-before (if forward? 149 | (cons old-cursor-line-normalized old-before) 150 | (cdr old-before))) 151 | (new-lines-after (if forward? 152 | (cdr old-after) 153 | (cons old-cursor-line-normalized old-after))) 154 | (new-n-before (+ (fun-terminal-pre-cursor-lines-length terminal) 155 | (if forward? 1 -1))) 156 | (new-n-after (+ (fun-terminal-post-cursor-lines-length terminal) 157 | (if forward? -1 1)))) 158 | (make-fun-terminal new-lines-before new-lines-after new-cursor-line new-n-before new-n-after))]))) 159 | 160 | (define (fun-terminal-forward-lines term [n-lines 1]) 161 | (let ((forward? (if (positive? n-lines) 162 | #t 163 | #f))) 164 | (define (inner-advance t n) 165 | (if (equal? 0 n) 166 | t 167 | (inner-advance (move-cursor-line t forward?) (sub1 n)))) 168 | (inner-advance term (abs n-lines)))) 169 | 170 | (define (fun-terminal-line-break terminal) 171 | (let* ((new-lines-before (cons (cursor-line->normal-line 172 | (fun-terminal-cursor-line terminal)) 173 | (fun-terminal-pre-cursor-lines terminal))) 174 | (new-cursor-line the-empty-cursor-line)) 175 | (struct-copy fun-terminal terminal 176 | [pre-cursor-lines new-lines-before] 177 | [pre-cursor-lines-length 178 | (add1 (fun-terminal-pre-cursor-lines-length terminal))] 179 | [cursor-line new-cursor-line]))) 180 | 181 | (define (fun-terminal-line-break-at-cursor terminal) 182 | (let* ((old-cursor-line (fun-terminal-cursor-line terminal)) 183 | (new-lines-before (cons (cursor-line-cells-before-cursor old-cursor-line) 184 | (fun-terminal-pre-cursor-lines terminal))) 185 | (new-cursor-line (make-cursor-line '() 186 | (cursor-line-cells-after-cursor old-cursor-line) 187 | 0))) 188 | (struct-copy fun-terminal terminal 189 | [pre-cursor-lines new-lines-before] 190 | [pre-cursor-lines-length 191 | (+ 1 (fun-terminal-pre-cursor-lines-length terminal))] 192 | [cursor-line new-cursor-line]))) 193 | 194 | (define (fun-terminal-add-blank-line-at-end term) 195 | (struct-copy fun-terminal term 196 | [post-cursor-lines (append (fun-terminal-post-cursor-lines term) '(()))] 197 | [post-cursor-lines-length (add1 (fun-terminal-post-cursor-lines-length term))])) 198 | 199 | (define (fun-terminal-edit-cursor-line term cl-func . cl-args) 200 | (struct-copy fun-terminal term 201 | [cursor-line (apply cl-func 202 | (cons (fun-terminal-cursor-line term) 203 | cl-args))])) 204 | 205 | (define (fun-terminal-insert-at-cursor terminal cell) 206 | (fun-terminal-edit-cursor-line terminal cursor-line-insert-cell cell)) 207 | 208 | (define (fun-terminal-delete-backwards-at-cursor terminal) 209 | (fun-terminal-edit-cursor-line terminal cursor-line-delete-cell-backward)) 210 | (define (fun-terminal-delete-forward-at-cursor terminal [n 1]) 211 | (fun-terminal-edit-cursor-line terminal cursor-line-delete-cell-forward n)) 212 | (define (fun-terminal-overwrite terminal cell) 213 | (fun-terminal-edit-cursor-line terminal cursor-line-overwrite cell)) 214 | (define (fun-terminal-overwrite-behind terminal cell) 215 | (fun-terminal-edit-cursor-line terminal cursor-line-overwrite-behind cell)) 216 | 217 | (define (fun-terminal-forward-cells term [n-cells 1]) 218 | (struct-copy fun-terminal term 219 | [cursor-line (cursor-line-advance-cursor 220 | (fun-terminal-cursor-line term) 221 | n-cells)])) 222 | 223 | (define (fun-terminal-delete-to-end-of-line term) 224 | (struct-copy fun-terminal term 225 | [cursor-line (struct-copy cursor-line (fun-terminal-cursor-line term) 226 | [cells-after-cursor '()])])) 227 | (define (fun-terminal-clear-from-start-of-line-to-cursor term) 228 | (fun-terminal-edit-cursor-line term cursor-line-clear-start-to-cursor)) 229 | 230 | (define (fun-terminal-delete-post-cursor-lines term) 231 | (struct-copy fun-terminal term 232 | [post-cursor-lines '()] 233 | [post-cursor-lines-length 0])) 234 | 235 | (define (fun-terminal-delete-n-pre-cursor-lines term n) 236 | (if ((fun-terminal-pre-cursor-lines-length term) . < . n) 237 | (struct-copy fun-terminal term 238 | [pre-cursor-lines '()] 239 | [pre-cursor-lines-length 0]) 240 | (struct-copy fun-terminal term 241 | [pre-cursor-lines (list-tail (fun-terminal-pre-cursor-lines term) n)] 242 | [pre-cursor-lines-length (- (fun-terminal-pre-cursor-lines-length term) n)]))) 243 | 244 | (define (fun-terminal-clear-line term) 245 | (struct-copy fun-terminal term 246 | [cursor-line the-empty-cursor-line])) 247 | 248 | (define (fun-terminal->lines-from-end terminal [style-cursor? #f]) 249 | ;; gives the lines in reverse order, because the last lines will be the ones used first 250 | (foldl cons 251 | (fun-terminal-pre-cursor-lines terminal) 252 | (cons (cursor-line->normal-line (fun-terminal-cursor-line terminal) style-cursor?) 253 | (fun-terminal-post-cursor-lines terminal)))) 254 | 255 | (define (fun-terminal-get-column term) 256 | (cursor-line-length-cells-before-cursor (fun-terminal-cursor-line term))) 257 | 258 | (define (fun-terminal-get-rows-from-end term) 259 | (fun-terminal-post-cursor-lines-length term)) 260 | 261 | (define (fun-terminal-get-num-rows term) 262 | (+ (fun-terminal-post-cursor-lines-length term) 263 | (fun-terminal-pre-cursor-lines-length term) 264 | 1)) 265 | 266 | (define (fun-terminal-scroll-region term n-pre n-post n-scrolls) 267 | (define (-scroll c-line before-lines after-lines n-before n-after n-scrolls) 268 | (let* ((region (append (reverse (take before-lines n-before)) 269 | (cons c-line (take after-lines n-after)))) 270 | (nn-scrolls (min n-scrolls (+ n-pre n-post 1))) 271 | (new-region (append (list-tail region nn-scrolls) 272 | (make-list nn-scrolls '()))) 273 | (new-before (append (reverse (take new-region n-before)) 274 | (list-tail before-lines n-before))) 275 | (new-c-line (list-ref new-region n-before)) 276 | (new-after (append (list-tail new-region (add1 n-before)) 277 | (list-tail after-lines n-after)))) 278 | (values new-before new-c-line new-after))) 279 | (let* ((forward? (positive? n-scrolls)) 280 | (before-lines (if forward? (fun-terminal-pre-cursor-lines term) 281 | (fun-terminal-post-cursor-lines term))) 282 | (after-lines (if forward? (fun-terminal-post-cursor-lines term) 283 | (fun-terminal-pre-cursor-lines term))) 284 | (nn-pre (if forward? n-pre n-post)) 285 | (nn-post (if forward? n-post n-pre)) 286 | (c-line (fun-terminal-cursor-line term)) 287 | (c-line-index (length (cursor-line-cells-before-cursor c-line))) 288 | (norm-line (cursor-line->normal-line (fun-terminal-cursor-line term)))) 289 | (define-values (new-before new-c-line new-after) 290 | (-scroll norm-line before-lines after-lines nn-pre nn-post (abs n-scrolls))) 291 | (struct-copy fun-terminal term 292 | [pre-cursor-lines (if forward? new-before new-after)] 293 | [post-cursor-lines (if forward? new-after new-before)] 294 | [cursor-line (normal-line->cursor-line new-c-line c-line-index)]))) 295 | -------------------------------------------------------------------------------- /rackterm/private/pty.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Library for handling all the system calls to unix to set up a PTY 4 | 5 | (require ffi/unsafe 6 | ffi/unsafe/define 7 | ffi/unsafe/port) 8 | (require racket/list racket/port racket/system racket/string) 9 | 10 | (provide (all-defined-out)) 11 | 12 | ;; How can I get these from the .h file automatically, so this won't just break? 13 | (define TIOCSWINSZ_gnu #x5414) 14 | (define TIOCGWINSZ_gnu #x5413) 15 | (define TIOCSCTTY_gnu #x540E) 16 | (define TIOCNOTTY_gnu #x5422) 17 | 18 | (define TIOCSWINSZ_freebsd #x80087467) 19 | (define TIOCGWINSZ_freebsd #x40087468) 20 | (define TIOCSCTTY_freebsd #x20007461) 21 | (define TIOCNOTTY_freebsd #x20007471) 22 | 23 | (define os-type (system-type 'os)) 24 | (define uname-s (if (equal? os-type 'windows) 25 | "windows" 26 | (string-trim (with-output-to-string 27 | (lambda () (system "uname -s")))))) 28 | (define freebsd-ioctls? (or (string-ci=? uname-s "FreeBSD") 29 | (string-ci=? uname-s "Darwin"))) 30 | ;; ioctl request parameters are ints in Linux, but longs in FreeBSD and MacOSX 31 | (define ioctl-req-type (if (or (equal? (system-type 'word) 64) 32 | freebsd-ioctls?) 33 | _long _int)) 34 | 35 | ;; set window size 36 | (define TIOCSWINSZ (if freebsd-ioctls? TIOCSWINSZ_freebsd TIOCSWINSZ_gnu)) 37 | ;; get window size 38 | (define TIOCGWINSZ (if freebsd-ioctls? TIOCGWINSZ_freebsd TIOCGWINSZ_gnu)) 39 | ;; set controlling terminal 40 | (define TIOCSCTTY (if freebsd-ioctls? TIOCSCTTY_freebsd TIOCSCTTY_gnu)) 41 | ;; disown the controlling terminal 42 | (define TIOCNOTTY (if freebsd-ioctls? TIOCNOTTY_freebsd TIOCNOTTY_gnu)) 43 | 44 | (define-ffi-definer define-pty (ffi-lib "libutil")) 45 | 46 | (define-cstruct _winsize ([ws_row _ushort] 47 | [ws_col _ushort] 48 | ;; ws_xpixel and ws_ypixel are apparently unused... 49 | [ws_xpixel _ushort] 50 | [ws_ypixel _ushort])) 51 | ;; when the window size changes, a SIGWINCH signal is sent to the foreground process group 52 | 53 | (define (new-winsize [width 80] [height 24]) 54 | (make-winsize height width 0 0)) 55 | 56 | 57 | 58 | 59 | (define (openpty [width 80] [height 24]) 60 | ;; name and termios can both be null, window size needs to be there, though. 61 | (define-pty openpty (_fun (amaster : (_ptr o _int)) 62 | (aslave : (_ptr o _int)) 63 | ;(slave-name : (_ptr o _string)) 64 | (slave-name : _pointer) 65 | (termios-ptr : _pointer) 66 | (winsize : (_ptr i _winsize)) 67 | -> (r : _int) 68 | -> (if (< 0 r) 69 | (error "openpty failed") 70 | (values amaster aslave slave-name)))) 71 | (let ((ws (new-winsize width height))) 72 | (define-values (master slave slave-name) (openpty #f #f ws)) 73 | (define-values (m-in m-out) (unsafe-file-descriptor->port master "mastername" '(read write))) 74 | (define-values (s-in s-out) (unsafe-file-descriptor->port slave "slavename" '(read write))) 75 | (values m-in m-out s-in s-out master slave))) 76 | 77 | 78 | 79 | (define (set-pty-size fd winsize) 80 | (define-pty ioctl (_fun 81 | (fd : _int) 82 | (request : ioctl-req-type) 83 | (winsize : (_ptr i _winsize)) 84 | -> (ret : _int) 85 | -> (when (< ret 0) (error "ioctl failed")))) 86 | (ioctl fd TIOCSWINSZ winsize)) 87 | 88 | (define (get-pty-size fd) 89 | (define-pty ioctl (_fun 90 | (fd : _int) 91 | (request : ioctl-req-type) 92 | (winsize : (_ptr o _winsize)) 93 | -> (ret : _int) 94 | -> (if (< ret 0) (error "ioctl failed") 95 | winsize))) 96 | (ioctl fd TIOCGWINSZ)) 97 | 98 | 99 | (define-ffi-definer define-libc (ffi-lib "libc" '("7" "6" #f))) 100 | 101 | (define argv-array-len 100) 102 | 103 | (define-libc setsid (_fun -> (ret : _int) 104 | -> (when (equal? ret -1) (error "setsid failed")))) 105 | 106 | (define-libc setpgid (_fun (pid : _int) (pgid : _int) 107 | -> (ret : _int) 108 | -> (if (equal? ret -1) 109 | (error "setpgid failed!") 110 | ret))) 111 | 112 | 113 | (define (execvp command . args) 114 | (define-libc execvp (_fun (file : _string) (argv : (_array/list _string argv-array-len)) 115 | -> (ret : _int) 116 | -> (error "execvp failed"))) 117 | (execvp command (append (list command) 118 | args 119 | (make-list (- argv-array-len 1 (length args)) #f)))) 120 | 121 | (define (set-controlling-tty fd) 122 | (define-pty ioctl (_fun 123 | (fd : _int) 124 | (request : ioctl-req-type) 125 | _pointer 126 | -> (ret : _int) 127 | -> (when (equal? ret -1) (error "ioctl failed to set the controlling terminal")))) 128 | (ioctl fd TIOCSCTTY #f)) 129 | 130 | (define (disown-tty) 131 | (define-pty ioctl (_fun 132 | (fd : _int) 133 | (request : ioctl-req-type) 134 | _pointer 135 | -> (ret : _int) 136 | -> (when (equal? ret -1) (error "ioctl failed to disown controlling terminal")))) 137 | (ioctl (unsafe-port->file-descriptor (current-input-port)) TIOCNOTTY #f)) 138 | 139 | -------------------------------------------------------------------------------- /rackterm/private/shell-trampoline.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; This is a wrapper to launch another program with proper settings to have job 4 | ;; control and let everything work properly in a terminal. My idea was to have 5 | ;; this in racket so no code in other languages would be needed. 6 | 7 | (module+ main 8 | (require "pty.rkt" ffi/unsafe/port) 9 | 10 | (define args (vector->list (current-command-line-arguments))) 11 | 12 | ;; this gives the process a new session ID 13 | (setsid) 14 | 15 | ;; Some terminal emulators use setpgid too, but it's failing for me 16 | ;(setpgid 0 0) 17 | 18 | ;; This makes it so emacs won't say "Could not open file: /dev/tty". 19 | ;; So far it's the only program that runs differently 20 | (set-controlling-tty (unsafe-port->file-descriptor (current-input-port))) 21 | 22 | (with-handlers ([(lambda (exn) #t) 23 | (lambda (exn) ((error-display-handler) (exn-message exn) exn))]) 24 | (apply execvp args))) 25 | 26 | -------------------------------------------------------------------------------- /rackterm/private/term-key-event.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define-struct key-event 6 | (char 7 | control 8 | meta 9 | super 10 | hyper 11 | shift 12 | ;; Some sort of configuration should tell the gui classes how to map mod1-5 to 13 | ;; meta, super, hyper... 14 | ) 15 | #:transparent) 16 | 17 | (define (no-mods-key-event key) 18 | (make-key-event key 19 | #f #f #f #f #f)) 20 | 21 | (define key-symbols 22 | '(backtab menu pause prior next end home left right up down escape print insert 23 | numpad0 numpad1 numpad2 numpad3 numpad4 numpad5 numpad6 numpad7 numpad8 numpad9 24 | numpad-enter multiply add subtract decimal divide 25 | f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 26 | wheel-up wheel-down wheel-left wheel-right 27 | )) 28 | 29 | (define (key . args) 30 | ;; convenience function to say eg. (key 'meta #\a) 31 | (define (mem x xs) 32 | ;; to standardize true values to #t 33 | (if (member x xs) #t #f)) 34 | (define (find-key-symbol syms) 35 | (cond [(null? syms) #f] 36 | [(member (car syms) key-symbols) (car syms)] 37 | [else (find-key-symbol (cdr syms))])) 38 | (let* ((fchar (memf char? args)) 39 | (char (if fchar (car fchar) #f)) 40 | (ch-sym (if char char 41 | ;; if it's not a char, look for one of the special key symbols 42 | (find-key-symbol args)))) 43 | (make-key-event ch-sym 44 | (mem 'control args) 45 | (mem 'meta args) 46 | (mem 'super args) 47 | (mem 'hyper args) 48 | (mem 'shift args)))) 49 | 50 | (define/contract (keys . args) 51 | ;; convenience to flatten key lists make with (key ...) 52 | (-> (listof (or/c key-event? (listof key-event?))) 53 | (listof key-event?)) 54 | (flatten args)) 55 | 56 | (define (at-least-one-aritize function) 57 | ;; the callbacks need to accept one argument for the character, but 58 | ;; aside from the default handler I bet most won't need it... 59 | (if (equal? 0 (procedure-arity function)) 60 | (lambda (_) (function)) 61 | function)) 62 | 63 | (define (get-handler-for-keymap keymap k-ev default) 64 | (cond 65 | [(dict-has-key? keymap k-ev) (dict-ref keymap k-ev)] 66 | [(dict-has-key? keymap 'default) (dict-ref keymap 'default)] 67 | [else default])) 68 | 69 | (define (fall-back-to-other-keymap keymap default-handler) 70 | (λ (k-ev) ((get-handler-for-keymap keymap 71 | k-ev 72 | default-handler) 73 | k-ev))) 74 | 75 | (define (make-keymap . args) 76 | ;; This should take key-events as keys (or the symbol 'default) and have functions that take a key-event as arguments 77 | (define (recur ht args) 78 | (cond [(null? args) ht] 79 | [(null? (cdr args)) (error "uneven argument list for keyhandler")] 80 | [else (begin (hash-set! ht (car args) (cadr args)) 81 | (recur ht (cddr args)))])) 82 | (recur (make-hash) args)) 83 | -------------------------------------------------------------------------------- /rackterm/private/terminal-canvas.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/gui/base) 4 | (require racket/class) 5 | (require racket/dict) 6 | (require "terminal.rkt") 7 | (require "term-key-event.rkt") 8 | 9 | (provide terminal-canvas% 10 | map-char-event-to-term-key-event 11 | ) 12 | 13 | ;;; YARR!!! Here be the ugliest code in the whole project! This file is a mess! 14 | 15 | ;;; TODO: 16 | ;;; - clean this crap up 17 | ;;; - add customization to set the 16 color palette map, input mapping 18 | ;;; - do key input mapping (arrow keys, etc) 19 | ;;; - do cursor better... 20 | ;;; - make it faster -- currently if anything on a line is different I redraw the line. 21 | ;;; I really should just redraw any cells that are different instead 22 | ;;; - wrap input that is too long after a resize down to fewer columns... 23 | 24 | (define the-char-bitmap-hash (make-hash)) 25 | 26 | (define terminal-canvas% 27 | (class canvas% 28 | (init-field [command-and-args (list (or (getenv "SHELL") "/bin/sh") "-i")]) 29 | (init-field [term-var "rackterm"]) 30 | (init-field [terminal 31 | (init-terminal (lambda () (send this refresh)) 32 | (lambda () (send this handle-subproc-ended)) 33 | (if (null? command-and-args) 34 | (list (or (getenv "SHELL") 35 | "/bin/sh") 36 | "-i") 37 | command-and-args) 38 | #:term-var term-var)]) 39 | 40 | (define/public (get-terminal) terminal) 41 | 42 | (init-field [set-title-callback void]) 43 | (define (set-parent-title) 44 | (when (send this has-focus?) 45 | (set-title-callback (terminal-title terminal)))) 46 | (define/override (on-focus event) 47 | (set-parent-title)) 48 | 49 | (init-field [font-size 12]) 50 | (define/public (get-font-size) font-size) 51 | (define/public (set-font-size! size) (set! font-size size)) 52 | 53 | (init-field [font-fallback-list 54 | '("DejaVu Sans Mono" 55 | "Ubuntu Mono" 56 | "Droid Sans Mono" 57 | "Liberation Mono" 58 | "Terminal" 59 | "Menlo" 60 | "Monaco" 61 | "Courier" 62 | "Courier New")]) 63 | (define/public (get-font-fallback-list) font-fallback-list) 64 | (define/public (set-font-fallback-list fonts) (set! font-fallback-list fonts)) 65 | (define (get-first-available-font fonts) 66 | (cond [(null? fonts) #f] 67 | [(member (car fonts) (get-face-list)) (car fonts)] 68 | [else (get-first-available-font (cdr fonts))])) 69 | 70 | (init-field [font-name "use first fallback"]) 71 | (define/public (get-font-name) font-name) 72 | (define/public (set-font-name! f) 73 | (set! font-name 74 | (get-first-available-font (cons f font-fallback-list)))) 75 | ;; set the font explicitly to trigger fallback behavior 76 | (send this set-font-name! (send this get-font-name)) 77 | 78 | (define last-width 0) 79 | (define last-height 0) 80 | (define last-lines '()) 81 | (define last-bitmap (make-object bitmap% 500 500)) 82 | (define last-dc (make-object bitmap-dc% last-bitmap)) 83 | (define (resize-maybe width height) 84 | (if (or (not (equal? width last-width)) 85 | (not (equal? height last-height))) 86 | (begin 87 | (set! last-width width) 88 | (set! last-height height) 89 | (terminal-set-size terminal width height) 90 | #t) 91 | #f)) 92 | 93 | (resize-maybe 80 24) ; call at startup so it initializes well 94 | 95 | (define (get-text-width-height) 96 | (define-values (width height _ __) (send (send this get-dc) get-text-extent "a")) 97 | (values width height)) 98 | 99 | (define (set-dc-font dc style) 100 | (send dc set-font (send the-font-list find-or-create-font 101 | (send this get-font-size) 102 | (send this get-font-name) 103 | 'modern ; default, decorative, roman, script, swiss, modern, symbol, system 104 | (if (style-italic style) 'italic 'normal) ; normal, italic, slant 105 | (if (style-bold style) 'bold 'normal) ; normal, bold, light 106 | (style-underline style) ; underline? 107 | 'default ; smoothing 108 | #f ; size-in-pixels 109 | 'aligned ; hinting 110 | ;; font-feature-settings -- I'm not sure these actually work right now. 111 | (hash 112 | ;;#|smallcaps|# "smcp" 1 113 | ;;#|subscript|# "subs" 1 114 | ) 115 | ))) 116 | 117 | (define (cell-size) 118 | (define (get-cell-size cell) 119 | (set-dc-font last-dc (cell-style cell)) 120 | (let-values [((width height _ __) 121 | (send last-dc 122 | get-text-extent 123 | (string (cell-character cell))))] 124 | (values width height))) 125 | (get-cell-size (make-cell #\@ default-style))) 126 | (define/public (get-xterm-size) 127 | (define-values (c-width c-height) (cell-size)) 128 | (define-values (x-size y-size) (send (send this get-dc) get-size)) 129 | (define (trunc num) (inexact->exact (truncate num))) 130 | (values (trunc (/ x-size c-width)) (trunc (/ y-size c-height)))) 131 | 132 | 133 | (define/override (on-paint) 134 | (send this set-label (terminal-title terminal)) 135 | (set-parent-title) 136 | (define dc (send this get-dc)) 137 | ;; I need to keep track of the coordinates and only draw lines inside the max 138 | (define-values (x-size y-size) (send dc get-size)) 139 | (define cur-x 0) 140 | (define cur-y y-size) ; start drawing at the bottom left 141 | ;; How do you just get one value and ignore the others? 142 | (define-values (current-font-width current-font-height) (get-text-width-height)) 143 | (define-values (xterm-width xterm-height) (send this get-xterm-size)) 144 | (define-values (cell-width cell-height) (cell-size)) 145 | (define (get-line-size line) 146 | (values (* cell-width (length line)) cell-height)) 147 | (define (print-terminal-line dc line really-print?) 148 | ;; ok, so since this has extra side effects I need to fake print it either way 149 | (define-values (line-width line-height) (get-line-size line)) 150 | (define-values (pixel-x-size pixel-y-size) (send dc get-size)) 151 | (set! cur-y (- cur-y line-height)) 152 | (set! cur-x 0) 153 | (when really-print? 154 | (send dc set-brush "black" 'solid) 155 | (send dc set-pen "black" 0 'solid) 156 | (send dc draw-rectangle cur-x cur-y pixel-x-size line-height) 157 | (for [(cell line)] 158 | (print-terminal-cell dc cell) 159 | (set! cur-x (+ cur-x cell-width)) 160 | ))) 161 | 162 | (define (print-terminal-cell dc cell) 163 | (unless (hash-has-key? the-char-bitmap-hash cell) 164 | (hash-set! the-char-bitmap-hash cell (make-cell-bitmap cell))) 165 | (send dc draw-bitmap (hash-ref the-char-bitmap-hash cell) cur-x cur-y)) 166 | 167 | (define (make-cell-bitmap cell) 168 | (define-values (cell-width cell-height) (cell-size)) 169 | (define (cell-char->string char) 170 | (if (list? char) 171 | (apply string char) 172 | (string char))) 173 | (let* [(cell-bitmap (make-object bitmap% (inexact->exact (truncate cell-width)) (inexact->exact (truncate cell-height)))) 174 | (cell-dc (make-object bitmap-dc% cell-bitmap)) 175 | (s (cell-style cell))] 176 | (set-dc-font cell-dc s) 177 | (send cell-dc set-background (style->color% s #f)) 178 | (send cell-dc clear) 179 | (send cell-dc set-text-background (style->color% s #f)) 180 | (send cell-dc set-text-foreground (style->color% s #t)) 181 | (send cell-dc draw-text (cell-char->string (cell-character cell)) 0 0 #t) 182 | (when (style-strikethrough s) 183 | (send cell-dc set-pen (style->color% s #t) 1 'solid) 184 | (send cell-dc draw-line 0 (/ cell-height 2) cell-width (/ cell-height 2))) 185 | cell-bitmap)) 186 | 187 | (define lines (terminal-get-lines terminal)) 188 | (define (repaint all?) 189 | ;; clear to start painting again... 190 | (when all? 191 | (send dc clear) 192 | (define-values (x-size y-size) (send (send this get-dc) get-size)) 193 | (set! last-bitmap (make-object bitmap% x-size y-size)) 194 | (set! last-dc (make-object bitmap-dc% last-bitmap)) 195 | (send last-dc set-background "black") 196 | (send last-dc clear) 197 | (send last-dc set-text-mode 'solid) 198 | ) 199 | 200 | (for [(line lines) 201 | (ol last-lines) 202 | #:break (< cur-y 0)] 203 | (if (or all? (not (equal? line ol))) 204 | (print-terminal-line last-dc line #t) 205 | (print-terminal-line last-dc line #f)) 206 | (send last-dc flush))) 207 | 208 | (define resized? (resize-maybe xterm-width xterm-height)) 209 | (if (or resized? (null? last-dc)) 210 | (repaint #t) 211 | (repaint #f)) 212 | 213 | (send dc draw-bitmap last-bitmap 0 0) 214 | (set! last-lines lines) 215 | (send dc flush)) ;; end on-paint 216 | 217 | (define/public (handle-subproc-ended) 218 | ;; TODO - this should be a parameter that can be set from outside... 219 | (define parent (send this get-parent)) 220 | (define focused? (send this has-focus?)) 221 | (send parent delete-child this) 222 | (define others (send parent get-children)) 223 | (for ((o others)) 224 | (send o refresh)) 225 | (if (null? others) 226 | (exit 0) 227 | (send (car others) focus)) 228 | (send parent reflow-container) 229 | ) 230 | 231 | (init-field [default-key-map key-command-map]) 232 | (define current-key-map default-key-map) 233 | 234 | (define (handle-event-giving-terminal-codes event) 235 | (let* ((k-ev (map-char-event-to-term-key-event event)) 236 | (handler (get-handler-for-keymap current-key-map 237 | k-ev 238 | received-key-default-handler)) 239 | (chars (cond 240 | [(dict? handler) (set! current-key-map handler)] 241 | [(procedure? handler) (begin (set! current-key-map default-key-map) 242 | (handler k-ev))] 243 | [else (error "got bad key handler:" handler)] 244 | ))) 245 | (if (sequence? chars) chars '()))) 246 | 247 | (define/override (on-char event) 248 | (let ((key (send event get-key-code))) 249 | (if (not (member key '(release #\nul))) 250 | (for ((char (handle-event-giving-terminal-codes event))) 251 | (when (char? char) 252 | ;(eprintf "sending to subproc: ~s\n" char) 253 | (send-char-to-terminal-process terminal char))) 254 | null))) 255 | (define/override (on-event event) 256 | (when (member (send event get-event-type) '(left-down right-down middle-down)) 257 | (send this focus))) 258 | 259 | (super-new) 260 | 261 | ;; start thread to listen for input from the subprocess 262 | (thread (terminal-input-listener terminal)) 263 | )) 264 | 265 | (define (control-version key) 266 | ;; return what the key would be if control were held down 267 | (define as-int (char->integer key)) 268 | (if (as-int . < . 128) 269 | (integer->char (bitwise-and 31 as-int)) 270 | key)) 271 | 272 | ;; TODO this should be a parameter to be configured 273 | (define bindings-ignore-shift #t) 274 | (define (map-char-event-to-term-key-event event) 275 | (let ((char (send event get-key-code)) 276 | (C (send event get-control-down)) 277 | (M (send event get-meta-down)) 278 | (A (send event get-alt-down)) 279 | ;; G for super 280 | (G (send event get-mod4-down)) 281 | (S (send event get-shift-down)) 282 | (H #f)) 283 | (let ((SS (if (and bindings-ignore-shift (char? char)) #f S))) 284 | (cond 285 | ;; backtab is important for key binding 286 | [(and (equal? char #\tab) S) (make-key-event 'backtab C (or M A) G H SS)] 287 | [else (make-key-event char C (or M A) G H SS)])))) 288 | 289 | (define meta-term-prefix #\033) 290 | (define super-term-prefix #f) 291 | (define hyper-term-prefix #f) 292 | 293 | (define (received-key-default-handler key-ev) 294 | (let ((meta (key-event-meta key-ev)) 295 | (ctl (key-event-control key-ev)) 296 | (sup (key-event-super key-ev)) 297 | (hyp (key-event-hyper key-ev)) 298 | (char (key-event-char key-ev))) 299 | (if (char? char) 300 | `(,@(if (and meta meta-term-prefix) (list meta-term-prefix) '()) 301 | ,@(if (and sup super-term-prefix) (list super-term-prefix) '()) 302 | ,@(if (and hyp hyper-term-prefix) (list hyper-term-prefix) '()) 303 | ,(if ctl (control-version char) char)) 304 | '()))) 305 | 306 | (define key-terminal-code-map 307 | (make-keymap 308 | 'default received-key-default-handler 309 | ;; these are the codes given by most terminals 310 | (key 'escape) (lambda _ "\e") 311 | (key #\backspace) (lambda _ (string #\rubout)) 312 | (key 'backtab) (lambda _ "\e[Z") 313 | ;; wheel up and down depend on some mode... but this is what seems to be given by default 314 | (key 'wheel-up) (lambda _ "\e[A") 315 | (key 'wheel-down) (lambda _ "\e[B") 316 | (key 'up) (lambda _ "\e[A") 317 | (key 'down) (lambda _ "\e[B") 318 | (key 'left) (lambda _ "\e[D") 319 | (key 'right) (lambda _ "\e[C") 320 | (key 'home) (lambda _ "\e[H") 321 | (key 'end) (lambda _ "\e[F") 322 | (key 'prior) (lambda _ "\e[5~") 323 | (key 'next) (lambda _ "\e[6~") 324 | (key #\rubout) (lambda _ "\e[3~") 325 | (key 'insert) (lambda _ "\e[2~") 326 | (key 'f1) (lambda _ "\eOP") 327 | (key 'f2) (lambda _ "\eOQ") 328 | (key 'f3) (lambda _ "\eOR") 329 | (key 'f4) (lambda _ "\eOS") 330 | (key 'f5) (lambda _ "\e[15~") 331 | (key 'f6) (lambda _ "\e[17~") 332 | (key 'f7) (lambda _ "\e[18~") 333 | (key 'f8) (lambda _ "\e[19~") 334 | (key 'f9) (lambda _ "\e[20~") 335 | (key 'f10) (lambda _ "\e[21~") 336 | (key 'f11) (lambda _ "\e[23~") 337 | (key 'f12) (lambda _ "\e[24~") 338 | (key 'shift 'f1) (lambda _ "\e[O1;2P") 339 | (key 'shift 'f2) (lambda _ "\e[O1;2Q") 340 | (key 'shift 'f3) (lambda _ "\e[O1;2R") 341 | (key 'shift 'f4) (lambda _ "\e[O1;2S") 342 | (key 'shift 'f5) (lambda _ "\e[15;2~") 343 | (key 'shift 'f6) (lambda _ "\e[17;2~") 344 | (key 'shift 'f7) (lambda _ "\e[18;2~") 345 | (key 'shift 'f8) (lambda _ "\e[19;2~") 346 | (key 'shift 'f9) (lambda _ "\e[20;2~") 347 | (key 'shift 'f10) (lambda _ "\e[21;2~") 348 | (key 'shift 'f11) (lambda _ "\e[23;2~") 349 | (key 'shift 'f12) (lambda _ "\e[24;2~") 350 | )) 351 | 352 | (define key-command-map 353 | (make-keymap 354 | 'default (fall-back-to-other-keymap key-terminal-code-map received-key-default-handler) 355 | (key 'control #\C) (lambda _ (eprintf "got C-shift-C\n")) 356 | )) 357 | -------------------------------------------------------------------------------- /rackterm/private/terminal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/draw) 3 | (require racket/list) 4 | (require racket/stream) 5 | (require racket/block) 6 | (require (for-syntax racket/base)) 7 | (require (for-syntax racket/syntax)) 8 | (require "pty.rkt") 9 | (require "fun-terminal.rkt") 10 | (require "cell.rkt") 11 | (require "console-code-parse.rkt") 12 | 13 | ;; This is the main file for the terminal library. It is to be wrapped by a program 14 | ;; to make eg. an xterm or a screen/tmux type emulator, or maybe even a framebuffer 15 | ;; terminal! 16 | (provide (all-from-out "cell.rkt") 17 | init-terminal 18 | terminal-get-lines 19 | terminal-title 20 | send-char-to-terminal-process 21 | terminal-set-size 22 | terminal-input-listener 23 | ) 24 | 25 | 26 | ;; TODO: 27 | ;; - the 'who' command doesn't show my racket xterms... Also of note: it doesn't show for 28 | ;; st terminals or finalterm either, so maybe it doesn't matter 29 | 30 | ;; Some notes: 31 | ;; - The spec uses 1 based cell addressing -- IE 1,1 is the origin at the top left corner. 32 | ;; I dislike 1 based indexing, so internally I use 0 based indexing. Things are 33 | ;; translated at the control sequence handling. 34 | ;; TODO - use 1-based indexing for rows and columns, since that's what the standard uses. Translating was a bad idea. 35 | 36 | (define-struct terminal 37 | (fun-terminal-norm 38 | fun-terminal-alt 39 | current-alt-screen-state 40 | process-in 41 | process-out 42 | ptm-fd 43 | current-width 44 | current-height 45 | redraw-callback 46 | current-char-handler 47 | current-cell-style 48 | current-scrolling-region ; (cons start-line, end-line) 49 | current-tab-stops ; sorted list of tab stop indices 50 | title 51 | margin-relative-addressing ; do the go-to-row/col commands base on the scrolling region -- DECOM 52 | subproc-ended-callback 53 | cursor-visible? 54 | cursor-blink? 55 | ) 56 | #:mutable) 57 | 58 | (define (init-terminal redraw-callback 59 | subproc-ended-callback 60 | command-and-args 61 | #:term-var [term-var "rackterm"]) 62 | (define (-init-terminal m-in m-out master-fd slave-fd redraw-callback) 63 | (make-terminal the-empty-fun-terminal 64 | the-empty-fun-terminal 65 | #f 66 | m-in 67 | m-out 68 | master-fd 69 | 80 70 | 24 71 | redraw-callback 72 | null 73 | default-style 74 | null 75 | '() 76 | "rackterm" 77 | #f ; margin relative addressing 78 | subproc-ended-callback 79 | #t ; cursor-visible? 80 | #t ; cursor-blink? 81 | )) 82 | (define-values (m-in m-out s-in s-out master-fd slave-fd) (openpty)) 83 | (define sub-env (environment-variables-copy (current-environment-variables))) 84 | (environment-variables-set! sub-env #"TERM" (string->bytes/utf-8 term-var)) 85 | (define-values (subproc sub-in sub-out sub-err) 86 | (parameterize ([current-environment-variables sub-env]) 87 | (apply subprocess (append (list s-out s-in 'stdout 88 | "/usr/bin/env" "racket" "-l" "rackterm/private/shell-trampoline" "--") 89 | command-and-args)))) 90 | (let ((new-term 91 | (-init-terminal m-in m-out master-fd slave-fd redraw-callback))) 92 | (terminal-set-default-tab-stops new-term) 93 | (thread (lambda () 94 | (subprocess-wait subproc) 95 | (subproc-ended-callback))) 96 | new-term)) 97 | 98 | 99 | (define (terminal-fun-terminal term) 100 | (if (terminal-current-alt-screen-state term) 101 | (terminal-fun-terminal-alt term) 102 | (terminal-fun-terminal-norm term))) 103 | (define (set-terminal-fun-terminal! term ft) 104 | (if (terminal-current-alt-screen-state term) 105 | (set-terminal-fun-terminal-alt! term ft) 106 | (set-terminal-fun-terminal-norm! term ft))) 107 | 108 | (define (terminal-mutate terminal fun-terminal-function) 109 | (set-terminal-fun-terminal! terminal 110 | (fun-terminal-function (terminal-fun-terminal 111 | terminal)))) 112 | (define (terminal-scroll-region term n-scrolls) 113 | (unless (equal? n-scrolls 0) 114 | (let* ((cur-row (terminal-get-row term)) 115 | (cursor-line-num (terminal-get-row term)) 116 | (region (terminal-current-scrolling-region term)) 117 | (region-start (if (null? region) 0 (car region))) 118 | (region-end (if (null? region) (sub1 (terminal-current-height term)) (cdr region))) 119 | (n-pre (cursor-line-num . - . region-start)) 120 | (n-post (region-end . - . cursor-line-num)) 121 | (sign (if (n-scrolls . < . 0) - +)) 122 | (nn-scrolls (sign (min (abs n-scrolls) (+ n-pre n-post 1))))) 123 | (terminal-mutate term (lambda (ft) (fun-terminal-scroll-region ft n-pre n-post nn-scrolls))) 124 | (terminal-go-to-row term cur-row)))) 125 | 126 | (define (terminal-delete-lines-with-scrolling-region term n-deletions) 127 | (let* ((cur (terminal-get-row term)) 128 | (region (terminal-current-scrolling-region term)) 129 | (region-end (if (null? region) 130 | (sub1 (terminal-current-height term)) 131 | (cdr region))) 132 | (cur-to-end (- region-end cur))) 133 | (terminal-mutate term (lambda (ft) 134 | (fun-terminal-scroll-region ft 0 cur-to-end n-deletions))))) 135 | (define (terminal-insert-lines-with-scrolling-region term n-inserts) 136 | (terminal-delete-lines-with-scrolling-region term (- n-inserts))) 137 | 138 | (define (terminal-insert-at-cursor term cell) 139 | (terminal-mutate term (lambda (ft) (fun-terminal-insert-at-cursor ft cell)))) 140 | (define (terminal-insert-after-cursor term cell) 141 | (terminal-insert-at-cursor term cell) 142 | (terminal-forward-chars term -1)) 143 | (define (terminal-delete-forward-at-cursor term n) 144 | (terminal-mutate term (lambda (ft) (fun-terminal-delete-forward-at-cursor ft n)))) 145 | (define (terminal-delete-backwards-at-cursor term) 146 | (terminal-mutate term (lambda (ft) (fun-terminal-delete-backwards-at-cursor ft)))) 147 | (define (terminal-clear-from-start-of-line-to-cursor term) 148 | (terminal-mutate term (lambda (ft) (fun-terminal-clear-from-start-of-line-to-cursor ft)))) 149 | (define (terminal-line-break-at-cursor term) 150 | (terminal-mutate term (lambda (ft) (fun-terminal-line-break-at-cursor ft)))) 151 | (define (terminal-delete-to-end-of-line term) 152 | (terminal-mutate term (lambda (ft) (fun-terminal-delete-to-end-of-line ft)))) 153 | (define (terminal-clear-current-line term) 154 | (terminal-mutate term (lambda (ft) (fun-terminal-clear-line ft)))) 155 | (define (terminal-forward-chars term [n 1]) 156 | (terminal-mutate term (lambda (ft) (fun-terminal-forward-cells ft n)))) 157 | (define (terminal-forward-lines term [n 1] #:scrollable? [scrollable? #t]) 158 | (define (-terminal-forward-lines term [n 1]) 159 | (terminal-mutate term (lambda (ft) (fun-terminal-forward-lines ft n)))) 160 | (if (or (not scrollable?) (null? (terminal-current-scrolling-region term))) 161 | (-terminal-forward-lines term n) 162 | (let* ((forward? (positive? n)) 163 | (cur (terminal-get-row term)) 164 | (region (terminal-current-scrolling-region term)) 165 | (end (if forward? (cdr region) 166 | (car region))) 167 | (moved (+ cur n)) 168 | (beyond (if ((if forward? > <) moved end) 169 | (- moved end) 170 | 0)) 171 | (to-move (- n beyond)) 172 | ;; If the cursor starts outside of the scrolling region and we try to keep 173 | ;; moving farther away, to-move and beyond will have opposite signs. 174 | ;; In this case we should just move, not move and scroll... 175 | (was-already-beyond (and (not (equal? 0 beyond)) 176 | (not (equal? (negative? to-move) 177 | (negative? beyond)))))) 178 | ; (eprintf "forward-n-lines ~a, cur ~a, region ~a, to-move ~a, to-scroll ~a, was-already-beyond ~a\n" 179 | ; n cur region to-move beyond was-already-beyond) 180 | (if was-already-beyond 181 | (-terminal-forward-lines term n) 182 | (begin 183 | (-terminal-forward-lines term to-move) 184 | (terminal-scroll-region term beyond)))))) 185 | 186 | (define (get-cell-before-cursor-same-row term) 187 | (fun-terminal-get-cell-before-cursor (terminal-fun-terminal term))) 188 | 189 | (define (terminal-overwrite term cell) 190 | (let ([pre-cell (get-cell-before-cursor-same-row term)]) 191 | (if (and (cell-is-combining-mark? cell) 192 | pre-cell) 193 | ;; instead of writing ahead, combine this cell with the previous one 194 | (terminal-mutate term 195 | (λ (ft) (fun-terminal-overwrite-behind 196 | ft (append-mark-cell pre-cell cell)))) 197 | (begin 198 | ;; This may need looking into when I want to handle re-wrapping on size changes 199 | (when (equal? (terminal-get-column term) (terminal-current-width term)) 200 | (terminal-forward-lines term 1) 201 | (terminal-go-to-column term 0)) 202 | (terminal-mutate term (lambda (ft) (fun-terminal-overwrite ft cell))))))) 203 | (define (terminal-append-line-at-end term) 204 | (terminal-mutate term (lambda (ft) (fun-terminal-add-blank-line-at-end ft)))) 205 | (define (terminal-clear-from-cursor-to-end term) 206 | (define n-lines (fun-terminal-post-cursor-lines-length (terminal-fun-terminal term))) 207 | (terminal-delete-to-end-of-line term) 208 | (terminal-mutate term (lambda (ft) (fun-terminal-delete-post-cursor-lines ft))) 209 | (for ((i (in-range n-lines))) 210 | (terminal-append-line-at-end term))) 211 | (define (terminal-insert-blank term [n 1] [after-cursor? #f]) 212 | (let ((insert (if after-cursor? 213 | terminal-insert-after-cursor 214 | terminal-insert-at-cursor))) 215 | (for ((i (in-range n))) 216 | (insert term (terminal-make-cell term #\space))))) 217 | (define (terminal-clear-from-start-to-cursor term) 218 | (define rows (terminal-get-row term)) 219 | (define cols (terminal-get-column term)) 220 | (terminal-clear-current-line term) 221 | (terminal-mutate term (lambda (ft) (fun-terminal-delete-n-pre-cursor-lines ft rows))) 222 | (for ((i (in-range rows))) 223 | (terminal-line-break-at-cursor term)) 224 | (terminal-insert-blank term cols)) 225 | 226 | (define (terminal-set-scrolling-region term start+1 end+1) 227 | (define start (sub1 start+1)) 228 | (define end (if (equal? end+1 'end) 229 | (sub1 (terminal-current-height term)) 230 | (sub1 end+1))) 231 | (if (and (equal? start 0) 232 | (equal? end (sub1 (terminal-current-height term)))) 233 | (set-terminal-current-scrolling-region! term null) 234 | (set-terminal-current-scrolling-region! term (cons start end)))) 235 | 236 | 237 | (define (terminal-set-size term width height) 238 | (define n-rows (fun-terminal-get-num-rows (terminal-fun-terminal term))) 239 | (define (grow-to-new-size) 240 | (define row-diff (- height n-rows)) 241 | (when (> row-diff 0) 242 | (for ((i (in-range row-diff))) 243 | (terminal-append-line-at-end term)))) 244 | 245 | (define state (terminal-current-alt-screen-state term)) 246 | (set-terminal-current-alt-screen-state! term (not state)) 247 | (grow-to-new-size) 248 | (set-terminal-current-alt-screen-state! term state) 249 | (grow-to-new-size) 250 | 251 | (set-terminal-current-width! term width) 252 | (set-terminal-current-height! term height) 253 | (set-pty-size (terminal-ptm-fd term) (new-winsize width height))) 254 | 255 | (define (terminal-set-tab-stop term) 256 | (let ((stops (terminal-current-tab-stops term)) 257 | (col (terminal-get-column term))) 258 | (unless (member col stops) 259 | (set-terminal-current-tab-stops! term (sort (cons col stops) <))))) 260 | (define (terminal-remove-tab-stop term) 261 | (set-terminal-current-tab-stops! term (remove (terminal-get-column term) 262 | (terminal-current-tab-stops term)))) 263 | (define (terminal-remove-all-tab-stops term) 264 | (set-terminal-current-tab-stops! term '())) 265 | (define (terminal-set-default-tab-stops term) 266 | (set-terminal-current-tab-stops! term (map (lambda (x) (* 8 x)) 267 | (stream->list (in-range 50))))) 268 | 269 | (define (terminal-go-to-next-tab-stop term) 270 | (define (find-tab tabs column) 271 | (cond [(null? tabs) 272 | (sub1 (terminal-current-width term))] 273 | [(<= (car tabs) column) 274 | (find-tab (cdr tabs) column)] 275 | [else (car tabs)])) 276 | (let* ((cur-col (terminal-get-column term)) 277 | (next-tab (find-tab (terminal-current-tab-stops term) cur-col)) 278 | (diff (- next-tab cur-col))) 279 | (terminal-forward-chars term diff))) 280 | 281 | (define (send-char-to-terminal-process term char) 282 | (write-char char (terminal-process-out term)) 283 | (flush-output (terminal-process-out term))) 284 | 285 | (define (terminal-get-lines term) 286 | (fun-terminal->lines-from-end (terminal-fun-terminal term) 287 | (terminal-cursor-visible? term))) 288 | 289 | (define (terminal-make-cell term char) 290 | (make-cell char (terminal-current-cell-style term))) 291 | 292 | (define (terminal-overwrite-character term char) 293 | ;(eprintf "writing character ~s\n" char) 294 | (terminal-overwrite term (terminal-make-cell term char))) 295 | 296 | (define (terminal-get-column term) 297 | (fun-terminal-get-column (terminal-fun-terminal term))) 298 | (define (terminal-get-row term) 299 | (let* ((from-end (fun-terminal-get-rows-from-end (terminal-fun-terminal term))) 300 | (size (terminal-current-height term))) 301 | (- size from-end 1))) 302 | 303 | (define (terminal-go-to-column term column) 304 | (let* ((cur-column (terminal-get-column term)) 305 | (diff (column . - . cur-column))) 306 | (terminal-forward-chars term diff))) 307 | (define (terminal-go-to-row term row) 308 | (let* ((cur-row (terminal-get-row term)) 309 | (relative-cur-row (if (and (terminal-margin-relative-addressing term) 310 | (terminal-current-scrolling-region term)) 311 | (- cur-row (car (terminal-current-scrolling-region term))) 312 | cur-row)) 313 | (diff (row . - . relative-cur-row))) 314 | (terminal-forward-lines term diff #:scrollable? #f))) 315 | (define (terminal-go-to-row-column term row [column 0]) 316 | (terminal-go-to-row term row) 317 | (terminal-go-to-column term column)) 318 | 319 | 320 | (define (terminal-input-listener term) 321 | (define ns (mk-terminal-namespace term)) 322 | (define (read-char-from-terminal-process term) 323 | (read-char (terminal-process-in term))) 324 | (lambda () 325 | (define (listener p-state) 326 | (let ((char (read-char-from-terminal-process term))) 327 | (if (not (eof-object? char)) 328 | (block 329 | (define-values (n-state output) (parse-char char #:parser-state p-state)) 330 | ;(terminal-interp term output) 331 | (when (not (null? output)) 332 | (with-handlers ([(λ _ #t) 333 | (λ e (eprintf "Caught exception during terminal eval of ~v:\n~a\n" output e))]) 334 | (eval output ns)) 335 | ((terminal-redraw-callback term))) 336 | (listener n-state)) 337 | (void)))) 338 | (sleep 0) 339 | (listener #f))) 340 | 341 | 342 | (define (set-term-color! term fg? . color-args) 343 | (let* ([color (cond [(equal? 3 (length color-args)) (apply make-color color-args)] 344 | [else (car color-args)])] 345 | [cur-style (terminal-current-cell-style term)] 346 | [fg (if fg? color (style-fg-color cur-style))] 347 | [bg (if fg? (style-bg-color cur-style) color)]) 348 | (set-terminal-current-cell-style! 349 | term 350 | (struct-copy style cur-style [fg-color fg] [bg-color bg])))) 351 | 352 | (define-syntax (def-set-style-bool stx) 353 | (syntax-case stx () 354 | [(_ attr) 355 | (with-syntax ([fname (format-id #'attr "set-style-~a!" #'attr)]) 356 | #'(define (fname term set?) 357 | (set-terminal-current-cell-style! 358 | term (struct-copy style 359 | (terminal-current-cell-style term) 360 | [attr set?]))))])) 361 | 362 | (def-set-style-bool bold) 363 | (def-set-style-bool italic) 364 | (def-set-style-bool underline) 365 | (def-set-style-bool blink) 366 | (def-set-style-bool reverse-video) 367 | (def-set-style-bool strikethrough) 368 | 369 | 370 | (define (terminal-forward-lines-column-0 term n) 371 | (terminal-go-to-column term 0) 372 | (terminal-forward-lines term n)) 373 | (define (terminal-do-esc-M term) 374 | (let* ((region (terminal-current-scrolling-region term)) 375 | (beginning (if (pair? region) (car region) 0))) 376 | (if (equal? beginning (terminal-get-row term)) 377 | (terminal-scroll-region term -1) 378 | (terminal-forward-lines term -1)))) 379 | (define (set-style-default! term) 380 | (set-terminal-current-cell-style! term default-style)) 381 | (define (set-style-fg-color! term . args) 382 | (apply set-term-color! `(,term #t ,@args))) 383 | (define (set-style-bg-color! term . args) 384 | (apply set-term-color! `(,term #f ,@args))) 385 | (define (terminal-clear term) 386 | (terminal-clear-from-start-to-cursor term) 387 | (terminal-clear-from-cursor-to-end term)) 388 | (define (terminal-replace-chars-with-space term n) 389 | (terminal-delete-forward-at-cursor term n) 390 | (terminal-insert-blank term n)) 391 | 392 | ;;; Some convenience functions for writing s-expressions 393 | (define (terminal-write-string term str) 394 | (for ((c str)) 395 | (terminal-overwrite-character term c))) 396 | (define (terminal-newline term) 397 | (terminal-forward-lines term 1)) 398 | (define (terminal-return term) 399 | (terminal-go-to-column term 0)) 400 | 401 | 402 | (define (mk-terminal-namespace term) 403 | #| 404 | TODO 405 | What I really want is to be able to put ALL of racket/base with require, or 406 | all of R5RS or some such, but without network access, file access, FFI access... 407 | Basically I want it to be all of racket or scheme, but with safety. 408 | 409 | Also, I would probably like to enable both r5rs AND racket separately -- 410 | perhaps default to one for normal forms that I get from standard terminal 411 | codes, but have two s-expression parsing codes, one for racket and one for scheme. 412 | 413 | At any rate, I need at least a way to let this reset so that one application can 414 | define things without worrying about what another has already defined... 415 | 416 | |# 417 | (define ns (make-base-empty-namespace)) 418 | (parameterize [(current-namespace ns)] 419 | (namespace-require '(only racket/base 420 | #%app 421 | #%datum 422 | quote 423 | quasiquote 424 | unquote 425 | unquote-splicing 426 | begin 427 | define 428 | lambda 429 | λ 430 | let 431 | apply 432 | ))) 433 | (define (tfun f) 434 | (λ args (apply f (cons term args)))) 435 | (define (def sym val) 436 | (namespace-set-variable-value! sym val #t ns)) 437 | (define-syntax-rule (tdef name func) 438 | (def name (tfun func))) 439 | 440 | (tdef 'terminal-write-char terminal-overwrite-character) 441 | (tdef 'terminal-write-string terminal-write-string) 442 | (tdef 'terminal-newline terminal-newline) 443 | (tdef 'terminal-return terminal-return) 444 | (tdef 'terminal-forward-chars terminal-forward-chars) 445 | (tdef 'terminal-crlf (λ (term [n 1]) 446 | (terminal-go-to-column term 0) 447 | (terminal-forward-lines term n))) 448 | (tdef 'terminal-forward-lines terminal-forward-lines) 449 | (tdef 'terminal-forward-lines-column-0 terminal-forward-lines-column-0) 450 | (tdef 'terminal-go-to-row terminal-go-to-row) 451 | (tdef 'terminal-go-to-column terminal-go-to-column) 452 | (tdef 'terminal-go-to-row-column terminal-go-to-row-column) 453 | (tdef 'terminal-do-esc-M terminal-do-esc-M) 454 | (tdef 'terminal-go-to-next-tab-stop terminal-go-to-next-tab-stop) 455 | (tdef 'terminal-set-tab-stop terminal-set-tab-stop) 456 | (tdef 'terminal-set-title! set-terminal-title!) 457 | (tdef 'set-terminal-margin-relative-addressing! set-terminal-margin-relative-addressing!) 458 | (tdef 'set-terminal-current-alt-screen-state! set-terminal-current-alt-screen-state!) 459 | (tdef 'set-terminal-cursor-visible! set-terminal-cursor-visible?!) 460 | (tdef 'set-terminal-cursor-blink! set-terminal-cursor-blink?!) 461 | (tdef 'set-style-default! set-style-default!) 462 | (tdef 'set-style-fg-color! set-style-fg-color!) 463 | (tdef 'set-style-bg-color! set-style-bg-color!) 464 | (tdef 'set-style-bold! set-style-bold!) 465 | (tdef 'set-style-italic! set-style-italic!) 466 | (tdef 'set-style-underline! set-style-underline!) 467 | (tdef 'set-style-blink! set-style-blink!) 468 | (tdef 'set-style-reverse-video! set-style-reverse-video!) 469 | (tdef 'set-style-strikethrough! set-style-strikethrough!) 470 | (tdef 'insert-blanks terminal-insert-blank) 471 | (tdef 'terminal-clear terminal-clear) 472 | (tdef 'terminal-clear-from-start-to-cursor terminal-clear-from-start-to-cursor) 473 | (tdef 'terminal-clear-from-cursor-to-end terminal-clear-from-cursor-to-end) 474 | (tdef 'terminal-clear-current-line terminal-clear-current-line) 475 | (tdef 'terminal-clear-from-start-of-line-to-cursor terminal-clear-from-start-of-line-to-cursor) 476 | (tdef 'terminal-delete-to-end-of-line terminal-delete-to-end-of-line) 477 | (tdef 'terminal-insert-lines-with-scrolling-region terminal-insert-lines-with-scrolling-region) 478 | (tdef 'terminal-delete-lines-with-scrolling-region terminal-delete-lines-with-scrolling-region) 479 | (tdef 'terminal-delete-forward-at-cursor terminal-delete-forward-at-cursor) 480 | (tdef 'terminal-scroll-region terminal-scroll-region) 481 | (tdef 'terminal-replace-chars-with-space terminal-replace-chars-with-space) 482 | (tdef 'terminal-remove-all-tab-stops terminal-remove-all-tab-stops) 483 | (tdef 'terminal-remove-tab-stop terminal-remove-tab-stop) 484 | (tdef 'terminal-set-scrolling-region terminal-set-scrolling-region) 485 | 486 | (tdef 'unknown-control-character (λ (t . r) (eprintf "unknown control character: ~s\n" r))) 487 | (tdef 'unknown-escape-character (λ (t . r) (eprintf "unknown escape character: ~s\n" r))) 488 | (tdef 'ignored-escape-sequence (λ (t . r) (eprintf "ignored escape sequence: ~s\n" r))) 489 | (tdef 'unknown-csi-terminator (λ (t . r) (eprintf "unknown csi terminator: ~s\n" r))) 490 | (tdef 'unknown-osc-sequence (λ (t . r) (eprintf "unknown osc sequence: ~s\n" r))) 491 | (tdef 'unknown-mode-set (λ (t . r) (eprintf "unknown mode set: ~s\n" r))) 492 | (tdef 'bell (λ (t . r) (eprintf "Bell!\n"))) 493 | 494 | ns) 495 | -------------------------------------------------------------------------------- /rackterm/rackterm.terminfo: -------------------------------------------------------------------------------- 1 | # TERMINFO file for rackterm 2 | # 3 | # Install: 4 | # tic rackterm.terminfo 5 | # 6 | # Usage: 7 | # export TERM=rackterm 8 | # 9 | # Useful reference for editing this: 10 | # http://pubs.opengroup.org/onlinepubs/7908799/xcurses/terminfo.html 11 | rackterm|racket terminal emulator, 12 | # Booleans are supposed to go first 13 | # to set a bool to false, write capname@ 14 | # screen erased with background color - NOT 15 | bce@, 16 | # can change pre-defined colors - NOT 17 | ccc@, 18 | # Numeric variables are next 19 | # colors#16777216, 20 | colors#256, pairs#32767, 21 | # italics 22 | sitm=\E[3m, ritm=\E[23m, 23 | # use normal clear command, not what xterm-256color uses 24 | rs1=\Ec, 25 | # no init string 26 | initc@, 27 | # disable these color setting things - use setab/setaf 28 | setf@, setb@, 29 | # this is how to set colors from the 256-color pallette 30 | setab=\E[%?%p1%{8}%<%t4%p1%d%e%p1%{16}%<%t10%p1%{8}%-%d%e48;5;%p1%d%;m, 31 | setaf=\E[%?%p1%{8}%<%t3%p1%d%e%p1%{16}%<%t9%p1%{8}%-%d%e38;5;%p1%d%;m, 32 | # 24-bit color, as supported by emacs (master branch, at least) 33 | setb24=\E[48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%dm, 34 | setf24=\E[38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%dm, 35 | # OK, it's basically like xterm... 36 | use=xterm-256color, 37 | 38 | -------------------------------------------------------------------------------- /rackterm/xterm.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; This is to be executed, running a GUI terminal emulator 4 | 5 | (require racket/class) 6 | (require racket/gui/base) 7 | (require racket/cmdline) 8 | (require racket/dict) 9 | (require "private/terminal.rkt") 10 | (require "private/terminal-canvas.rkt") 11 | (require "private/term-key-event.rkt") 12 | 13 | ;; to run tic 14 | (require racket/system) 15 | (require racket/runtime-path) 16 | 17 | 18 | (define font-size (make-parameter 12)) 19 | (define font-name (make-parameter "use first fallback")) 20 | (define command (make-parameter #f)) 21 | (define term-var (make-parameter "rackterm")) 22 | 23 | (define command-args 24 | (command-line 25 | #:once-each 26 | [("--font-name") fontname 27 | "Use the given font." 28 | (font-name fontname)] 29 | [("--font-size") size 30 | "Use the given font size." 31 | (font-size (string->number size))] 32 | [("--term-var") TERM 33 | "override default TERM value of 'rackterm'." 34 | (term-var TERM)] 35 | [("-e" "--command") cmd 36 | "Execute the given command as the shell." 37 | (command cmd)] 38 | #:args args 39 | args)) 40 | 41 | (define command-and-args (if (command) 42 | (append (list (command)) command-args) 43 | (list (or (getenv "SHELL") 44 | "/bin/sh") 45 | "-i"))) 46 | 47 | (define xterm-frame% 48 | (class frame% 49 | (init-field 50 | [handling-keymap 51 | (make-keymap (key 'control #\G) (lambda _ (send this add-canvas)) 52 | (key 'control #\N) (lambda _ (send this focus-next)) 53 | )]) 54 | 55 | (define current-keymap handling-keymap) 56 | (define/public (set-current-keymap kmap) 57 | (set! current-keymap kmap)) 58 | (define/override (on-subwindow-char receiver event) 59 | (define key-ev (map-char-event-to-term-key-event event)) 60 | (define handler (get-handler-for-keymap current-keymap key-ev (λ _ 'pass-through))) 61 | (cond [(dict? handler) (begin 62 | (set! current-keymap handler) 63 | #t)] 64 | ;; if the handler returns 'pass-through, let control pass through to the child 65 | [handler (begin 66 | (set! current-keymap handling-keymap) 67 | (define ret (handler key-ev)) 68 | (not (equal? ret 'pass-through)))] 69 | ;; if handler is #f but the keymap was not the default, eat the key (don't pass it) 70 | [(not (equal? current-keymap handling-keymap)) #t] 71 | ;; otherwise just let the kids handle it. 72 | [else #f])) 73 | 74 | (define/public (add-canvas) 75 | (let ((c (new terminal-canvas% 76 | [parent this] 77 | [font-size (font-size)] 78 | [font-name (font-name)] 79 | [term-var (term-var)] 80 | [command-and-args command-and-args] 81 | [set-title-callback (lambda (title) (send this set-label title))] 82 | [horiz-margin 2] 83 | [vert-margin 2] 84 | ))) 85 | (send c focus) 86 | c)) 87 | (define/public (focus-next) 88 | (let* ((children (send this get-children)) 89 | (focused-child (memf (lambda (c) (send c has-focus?)) children)) 90 | (next-child (if focused-child (cdr focused-child) #f)) 91 | (to-focus (if (or (null? next-child) (not next-child)) 92 | (car children) 93 | (car next-child)))) 94 | (send to-focus focus))) 95 | 96 | (super-new))) 97 | 98 | 99 | (module+ main 100 | ;; Let's just run tic here and not have others worry about this terminfo crap. 101 | (define-runtime-path terminfo-file "rackterm.terminfo") 102 | 103 | (define (do-main) 104 | ;; This is in a function because otherwise it prints stuff for being 105 | ;; at the top level 106 | (system* (find-executable-path "tic") "-x" (path->string terminfo-file)) 107 | 108 | (define frame (new xterm-frame% 109 | [label "racket xterm"] 110 | [width 800] 111 | [height 800] 112 | )) 113 | 114 | (send frame show #t) 115 | (send frame add-canvas) 116 | (void)) 117 | 118 | (do-main)) 119 | 120 | 121 | --------------------------------------------------------------------------------