From 77c76949e5998b6914e71aae97c953b8ac796f57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Jul 2020 14:35:10 +0200 Subject: vulgar fixups. --- module/output/terminal.scm | 11 ++++++++++- module/vulgar.scm | 22 ++++++++++++++-------- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index 52d34331..20740cac 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -146,7 +146,16 @@ ((#\k #\K) (unless (= cur-event 0) (set! cur-event = (- 1)))) ((#\g) (set! cur-event 0)) - ((#\G) (set! cur-event (1- (length events))))) + ((#\G) (set! cur-event (1- (length events)))) + ((#\() (set-cursor-pos 0 (1- height)) + (let* ((attr (make-termios))) + (tcgetattr! attr) + (set! (lflag attr) (logior ECHO (lflag attr))) + (tcsetattr! attr) + (display (readline ">") + (current-error-port)) + (set! (lflag attr) (logand (lognot ECHO) (lflag attr))) + (tcsetattr! attr)))) (when (or (eof-object? char) (memv char '(#\q))) diff --git a/module/vulgar.scm b/module/vulgar.scm index 80bff5f6..5c98d719 100644 --- a/module/vulgar.scm +++ b/module/vulgar.scm @@ -11,13 +11,20 @@ #:export (with-vulgar)) (define-public (cls) - (display "\x1b[H") ; Move cursor to the origin - (display "\x1b[J") ; Clear everything after cursor - ) + ;; [H]ome, [J]: clear everything after + (display "\x1b[H\x1b[J")) + +(define-public (set-cursor-pos x y) + (format #t "\x1b[~a;~aH" + (1+ y) (1+ x))) + (define-syntax with-vulgar (syntax-rules () ((_ thunk) + (with-vulgar (bitwise-not (bitwise-ior ECHO ICANON)) + thunk)) + ((_ bits thunk) (let* ((ifd (current-input-port)) (ofd (current-output-port)) (iattr (make-termios)) @@ -29,12 +36,11 @@ (tcgetattr! oattr ofd) ;; Store current settings to enable resetting the terminal later - (set! iattr* (copy-termios iattr)) - (set! oattr* (copy-termios oattr)) + (set! iattr* (copy-termios iattr) + oattr* (copy-termios oattr) - (let ((bits (bitwise-not (bitwise-ior ECHO ICANON)))) - (set! (lflag iattr) (bitwise-and (lflag iattr) bits)) - (set! (lflag oattr) (bitwise-and (lflag oattr) bits))) + (lflag iattr) (bitwise-and bits (lflag iattr)) + (lflag oattr) (bitwise-and bits (lflag oattr))) (tcsetattr! iattr ifd) (tcsetattr! oattr ofd)) -- cgit v1.2.3