Avoid use of lexer, preferring regexp-try-match and explicit read-byte/read-char.

ansi/lcd-terminal.rkt

@@ -5,12 +5,12 @@
          (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))
 
+(define lcd-terminal-utf-8? (make-parameter #t))
+
 (struct unknown-escape-sequence (string) #:prefab)
 (struct key (value modifiers) #:prefab)
 
@@ -24,12 +24,6 @@
 (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)))
@@ -62,37 +56,33 @@
                             [8 (ctor 'end)]
                             [_ (simple-key (unknown-escape-sequence lexeme))])))
 
-(define (analyze-vt-bracket-key lexeme)
+(define (analyze-vt-bracket-key lexeme params mainchar)
-  (match lexeme
+  (match mainchar
-    [(pregexp "\e\\[([0-9]+(;[0-9]+)*)?(.)" (list _ paramstr _ mainchar))
+    ["~" (analyze-vt-tildeish-key lexeme params simple-key)]
-     (define params (and paramstr (map string->number (string-split paramstr ";"))))
+    ["$" (analyze-vt-tildeish-key lexeme params S-)]
-     (match mainchar
+    ["^" (analyze-vt-tildeish-key lexeme params C-)]
-       ["~" (analyze-vt-tildeish-key lexeme params simple-key)]
+    ["@" (analyze-vt-tildeish-key lexeme params C-S-)]
-       ["$" (analyze-vt-tildeish-key lexeme params S-)]
+    ["A" (decode-shifting params 'up)]
-       ["^" (analyze-vt-tildeish-key lexeme params C-)]
+    ["B" (decode-shifting params 'down)]
-       ["@" (analyze-vt-tildeish-key lexeme params C-S-)]
+    ["C" (decode-shifting params 'right)]
-       ["A" (decode-shifting params 'up)]
+    ["D" (decode-shifting params 'left)]
-       ["B" (decode-shifting params 'down)]
+    ["E" (decode-shifting params 'begin)]
-       ["C" (decode-shifting params 'right)]
+    ["F" (decode-shifting params 'end)]
-       ["D" (decode-shifting params 'left)]
+    ["G" (decode-shifting params 'begin)] ;; linux console (!)
-       ["E" (decode-shifting params 'begin)]
+    ["H" (decode-shifting params 'home)]
-       ["F" (decode-shifting params 'end)]
+    ["J" #:when (equal? params '(2)) (S- 'home)] ;; st, http://st.suckless.org/
-       ["G" (decode-shifting params 'begin)] ;; linux console (!)
+    ["J" #:when (not params) (C- 'end)] ;; st, http://st.suckless.org/
-       ["H" (decode-shifting params 'home)]
+    ["K" #:when (equal? params '(2)) (S- 'delete)] ;; st, http://st.suckless.org/
-       ["J" #:when (equal? params '(2)) (S- 'home)] ;; st, http://st.suckless.org/
+    ["K" #:when (not params) (S- 'end)] ;; st, http://st.suckless.org/
-       ["J" #:when (not params) (C- 'end)] ;; st, http://st.suckless.org/
+    ["L" (C- 'insert)]                  ;; st, http://st.suckless.org/
-       ["K" #:when (equal? params '(2)) (S- 'delete)] ;; st, http://st.suckless.org/
+    ["M" (C- 'delete)]                  ;; st, http://st.suckless.org/
-       ["K" #:when (not params) (S- 'end)] ;; st, http://st.suckless.org/
+    ["P" (simple-key 'delete)]          ;; st, http://st.suckless.org/
-       ["L" (C- 'insert)] ;; st, http://st.suckless.org/
+    ["Z" (C-S- #\I)] ;; TODO: should this instead be a 'backtab key?
-       ["M" (C- 'delete)] ;; st, http://st.suckless.org/
+    ["a" (S- 'up)]
-       ["P" (simple-key 'delete)] ;; st, http://st.suckless.org/
+    ["b" (S- 'down)]
-       ["Z" (C-S- #\I)] ;; TODO: should this instead be a 'backtab key?
+    ["c" (S- 'right)]
-       ["a" (S- 'up)]
+    ["d" (S- 'left)]
-       ["b" (S- 'down)]
+    ["h" #:when (equal? params '(4)) (simple-key 'insert)] ;; st, http://st.suckless.org/
-       ["c" (S- 'right)]
-       ["d" (S- 'left)]
-       ["h" #:when (equal? params '(4)) (simple-key 'insert)] ;; st, http://st.suckless.org/
-       [_ (simple-key (unknown-escape-sequence lexeme))])]
     [_ (simple-key (unknown-escape-sequence lexeme))]))
 
 (define (analyze-vt-O-mainchar lexeme mainchar)
@@ -132,26 +122,43 @@
     ["M" (add-modifier 'control (simple-key #\M))] ;; keypad enter (rxvt)
     [_ (simple-key (unknown-escape-sequence lexeme))]))
 
-(define (analyze-vt-O-key lexeme)
+(define (interpret-ascii-code b)
-  (match lexeme
+  (cond
-    [(pregexp "\eO(.)(.)" (list _ v-plus-one-str mainchar))
+   [(<= #x00 b #x1f) (C- (integer->char (+ b (char->integer #\A) -1)))]
-     ;; screen generates shifting escapes for the keypad like this
+   [(<= #x20 b #x7e) (simple-key (integer->char b))]
-     (decode-shifting-number (string->number v-plus-one-str)
+   [(= b #x7f) (simple-key 'backspace)]))
-                             (analyze-vt-O-mainchar lexeme mainchar))]
-    [(pregexp "\eO(.)" (list _ mainchar))
-     (analyze-vt-O-mainchar lexeme mainchar)]
-    [other (simple-key (unknown-escape-sequence lexeme))]))
 
-(define lex-lcd-input
+(define (lex-lcd-input port)
-  (lexer [(eof) eof]
+  (cond
-         [(char-range #\u00 #\u1f) (control-character lexeme 0 C-)]
+   [(eof-object? (peek-byte port)) eof]
-         [(char-range #\u20 #\u7e) (simple-key (string-ref lexeme 0))]
+   [(or (regexp-try-match #px"^\e\\[([0-9]+(;[0-9]+)*)?(.)" port)
-         [#\u7f (simple-key 'backspace)]
+        (regexp-try-match #px#"^\x9b([0-9]+(;[0-9]+)*)?(.)" port)) =>
-         [(char-range #\u80 #\u9f) (control-character lexeme -128 C-M-)]
+    (lambda (match-result)
-         [(char-range #\u80 #\ufe) (M- (char+ (string-ref lexeme 0) -128))]
+      (match-define (list lexeme parambytes _ mainbytes) match-result)
-         [#\uff (M- 'backspace)]
+      (define params (and parambytes
-         [(:: "\e[" (:? (:+ numeric) (:* #\; (:+ numeric))) any-char)
+                          (map string->number (string-split (bytes->string/utf-8 parambytes) ";"))))
-          (analyze-vt-bracket-key lexeme)]
+      (analyze-vt-bracket-key lexeme params (bytes->string/utf-8 mainbytes)))]
-         [(:: "\eO" any-char) (analyze-vt-O-key lexeme)]
+   [(regexp-try-match #px"^\eO([0-9])(.)" port) =>
-         [(:: "\eO" numeric any-char) (analyze-vt-O-key lexeme)]
+    ;; screen generates shifting escapes for the keypad like this
-         ))
+    (lambda (match-result)
+      (match-define (list lexeme v-plus-one-bytes mainbytes) match-result)
+      (decode-shifting-number (string->number (bytes->string/utf-8 v-plus-one-bytes))
+                              (analyze-vt-O-mainchar lexeme (bytes->string/utf-8 mainbytes))))]
+   [(regexp-try-match #px"^\eO(.)" port) =>
+    (lambda (match-result)
+      (match-define (list lexeme mainbytes) match-result)
+      (analyze-vt-O-mainchar lexeme (bytes->string/utf-8 mainbytes)))]
+   ;; Characters between #\u80 and #\uff are ambiguous because in
+   ;; some terminals, the high bit is set to indicate meta, and in
+   ;; others, they are plain UTF-8 characters. We let the user
+   ;; distinguish via the lcd-terminal-utf-8? parameter.
+   [(not (lcd-terminal-utf-8?))
+    (define b (read-byte port))
+    (if (< b 128)
+        (interpret-ascii-code b)
+        (add-modifier 'meta (interpret-ascii-code (- b 128))))]
+   [else
+    (define b (char->integer (read-char port)))
+    (if (< b 128)
+        (interpret-ascii-code b)
+        (simple-key (integer->char b)))]))