aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2022-04-05 16:35:02 +0200
committerHugo Hörnquist <hugo@lysator.liu.se>2022-04-05 16:56:14 +0200
commitc80aa88d3609d39dfb889aac3301775b14be4b44 (patch)
tree5815ad4d0a3491e144ba3538e7ff7c0b81fbb937
parentMade sidebar date headings sticky. (diff)
downloadcalp-c80aa88d3609d39dfb889aac3301775b14be4b44.tar.gz
calp-c80aa88d3609d39dfb889aac3301775b14be4b44.tar.xz
with-vulgar now uses alternative screen.
-rw-r--r--module/vulgar.scm68
1 files changed, 36 insertions, 32 deletions
diff --git a/module/vulgar.scm b/module/vulgar.scm
index 5ddea738..20b93164 100644
--- a/module/vulgar.scm
+++ b/module/vulgar.scm
@@ -19,35 +19,39 @@
(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))
- (oattr (make-termios))
- iattr* oattr*)
- (dynamic-wind
- (lambda ()
- (tcgetattr! iattr ifd)
- (tcgetattr! oattr ofd)
-
- ;; Store current settings to enable resetting the terminal later
- (set! iattr* (copy-termios iattr)
- oattr* (copy-termios oattr)
-
- (lflag iattr) (bitwise-and bits (lflag iattr))
- (lflag oattr) (bitwise-and bits (lflag oattr)))
-
- (tcsetattr! iattr ifd)
- (tcsetattr! oattr ofd)
- (system "tput civis"))
- thunk
- (lambda ()
- (tcsetattr! iattr* ifd)
- (tcsetattr! oattr* ofd)
- (system "tput cnorm")
- ))))))
+(define (with-vulgar . args)
+ (apply
+ (case-lambda
+ ((thunk)
+ (with-vulgar (bitwise-not (bitwise-ior ECHO ICANON))
+ thunk))
+ ((bits thunk)
+ (let* ((ifd (current-input-port))
+ (ofd (current-output-port))
+ (iattr (make-termios))
+ (oattr (make-termios))
+ iattr* oattr*)
+ (dynamic-wind
+ (lambda ()
+ (tcgetattr! iattr ifd)
+ (tcgetattr! oattr ofd)
+
+ ;; Store current settings to enable resetting the terminal later
+ (set! iattr* (copy-termios iattr)
+ oattr* (copy-termios oattr)
+
+ (lflag iattr) (bitwise-and bits (lflag iattr))
+ (lflag oattr) (bitwise-and bits (lflag oattr)))
+
+ (tcsetattr! iattr ifd)
+ (tcsetattr! oattr ofd)
+ (format #t "\x1b[?1049h")
+ (system "tput civis"))
+ thunk
+ (lambda ()
+ (tcsetattr! iattr* ifd)
+ (tcsetattr! oattr* ofd)
+ (format #t "\x1b[?1049l")
+ (system "tput cnorm")
+ )))))
+ args))