Lowest common denominator terminal

lcd-terminal.rkt

@@ -0,0 +1,129 @@
+#lang racket/base
+;; Lowest Common Denominator terminal.
+
+(provide (struct-out key)
+         (struct-out unknown-escape-sequence)
+         lex-lcd-input)
+
+(require parser-tools/lex)
+(require (prefix-in : parser-tools/lex-sre))
+(require racket/set)
+(require racket/match)
+(require (only-in racket/string string-split))
+
+(struct unknown-escape-sequence (string) #:prefab)
+(struct key (value modifiers) #:prefab)
+
+(define (simple-key value) (key value (set)))
+(define (S- value) (key value (set 'shift)))
+(define (C- value) (key value (set 'control)))
+(define (M- value) (key value (set 'meta)))
+(define (C-S- value) (key value (set 'control 'shift)))
+(define (C-M- value) (key value (set 'control 'meta)))
+
+(define (add-modifier modifier k)
+  (struct-copy key k [modifiers (set-add (key-modifiers k) modifier)]))
+
+(define (char+ c offset)
+  (integer->char (+ (char->integer c) offset)))
+
+(define (control-character lexeme offset ctor)
+  (ctor (char+ (string-ref lexeme 0) (+ (char->integer #\A) -1 offset))))
+
+(define (decode-shifting-number v-plus-one k)
+  (define v (- v-plus-one 1))
+  (let* ((k (if (zero? (bitwise-and v 1)) k (add-modifier 'shift k)))
+         (k (if (zero? (bitwise-and v 2)) k (add-modifier 'meta k)))
+         (k (if (zero? (bitwise-and v 4)) k (add-modifier 'control k))))
+    k))
+
+(define (decode-shifting params value)
+  (match params
+    [(list 1 v-plus-one) (decode-shifting-number v-plus-one (simple-key value))]
+    [_ (simple-key value)] ;; bit of a cop-out
+    ))
+
+(define (analyze-vt-tildeish-key lexeme params ctor)
+  (match params
+    [(list a b) (analyze-vt-tildeish-key* lexeme ctor a b)]
+    [(list a) (analyze-vt-tildeish-key* lexeme ctor a 1)]
+    [_ (simple-key (unknown-escape-sequence lexeme))]))
+
+(define (analyze-vt-tildeish-key* lexeme ctor a b)
+  (decode-shifting-number b
+                          (match a
+                            [1 (ctor 'home)] ;; linux console
+                            [2 (ctor 'insert)]
+                            [3 (ctor 'delete)]
+                            [4 (ctor 'end)] ;; linux console
+                            [5 (ctor 'page-up)]
+                            [6 (ctor 'page-down)]
+                            [7 (ctor 'home)]
+                            [8 (ctor 'end)]
+                            [_ (simple-key (unknown-escape-sequence lexeme))])))
+
+(define (analyze-vt-bracket-key lexeme)
+  (match lexeme
+    [(pregexp "\e\\[([0-9]+(;[0-9]+)*)?(.)" (list _ paramstr _ mainchar))
+     (define params (and paramstr (map string->number (string-split paramstr ";"))))
+     (match mainchar
+       ["~" (analyze-vt-tildeish-key lexeme params simple-key)]
+       ["$" (analyze-vt-tildeish-key lexeme params S-)]
+       ["^" (analyze-vt-tildeish-key lexeme params C-)]
+       ["@" (analyze-vt-tildeish-key lexeme params C-S-)]
+       ["A" (decode-shifting params 'up)]
+       ["B" (decode-shifting params 'down)]
+       ["C" (decode-shifting params 'right)]
+       ["D" (decode-shifting params 'left)]
+       ["H" (decode-shifting params 'home)]
+       ["F" (decode-shifting params 'end)]
+       ["Z" (C-S- #\I)] ;; TODO: should this instead be a 'backtab key?
+       ["a" (S- 'up)]
+       ["b" (S- 'down)]
+       ["c" (S- 'right)]
+       ["d" (S- 'left)]
+       [_ (simple-key (unknown-escape-sequence lexeme))])]
+    [_ (error 'analyze-vt-bracket-key "Unexpected input sequence from lexer: ~v" lexeme)]))
+
+(define (analyze-vt-O-key lexeme)
+  (match lexeme
+    [(pregexp "\eO(.)" (list _ mainchar))
+     (match mainchar
+       ["a" (C- 'up)]
+       ["b" (C- 'down)]
+       ["c" (C- 'right)]
+       ["d" (C- 'left)]
+       ["A" (simple-key 'up)] ;; kcuu1
+       ["B" (simple-key 'down)] ;; kcud1
+       ["C" (simple-key 'right)] ;; kcuf1
+       ["D" (simple-key 'left)] ;; kcub1
+       ["H" (simple-key 'home)] ;; khome
+       ["F" (simple-key 'end)] ;; kend
+       [_ (simple-key (unknown-escape-sequence lexeme))])]
+    [other (simple-key (unknown-escape-sequence lexeme))]))
+
+(define lex-lcd-input
+  (lexer [(eof) eof]
+         [(char-range #\u00 #\u1f) (control-character lexeme 0 C-)]
+         [(char-range #\u20 #\u7e) (simple-key (string-ref lexeme 0))]
+         [#\u7f (simple-key 'backspace)]
+         [(char-range #\u80 #\u9f) (control-character lexeme -128 C-M-)]
+         [(char-range #\u80 #\ufe) (M- (char+ (string-ref lexeme 0) -128))]
+         [#\uff (M- 'backspace)]
+         [(:: "\e[" (:? (:+ numeric) (:* #\; (:+ numeric))) any-char)
+          (analyze-vt-bracket-key lexeme)]
+         [(:: "\eO" any-char)
+          (analyze-vt-O-key lexeme)]
+         ))
+
+(module+ main
+  (require "tty-raw-extension")
+  (tty-raw!)
+  (let loop ()
+    (match (lex-lcd-input (current-input-port))
+      [(? eof-object?) (void)]
+      [(== (C- #\D)) (void)]
+      [key
+       (printf "Key: ~v\r\n" key)
+       (loop)]))
+  (tty-restore!))