From 3bdc5e083f9f3063c59ffed18fe062c9a9e166dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 1 Jun 2019 21:38:11 +0200 Subject: Rename {terminal => vulgar}. --- module/vulgar/escape.scm | 42 +++++++++++++ module/vulgar/termios.scm | 155 ++++++++++++++++++++++++++++++++++++++++++++++ module/vulgar/util.scm | 46 ++++++++++++++ 3 files changed, 243 insertions(+) create mode 100644 module/vulgar/escape.scm create mode 100644 module/vulgar/termios.scm create mode 100644 module/vulgar/util.scm (limited to 'module/vulgar') diff --git a/module/vulgar/escape.scm b/module/vulgar/escape.scm new file mode 100644 index 00000000..513e66d2 --- /dev/null +++ b/module/vulgar/escape.scm @@ -0,0 +1,42 @@ +;;; Module for terminal (ANSI) escape codes. + +(define-module (vulgar escape) + #:use-module (srfi srfi-60) + #:use-module (vulgar termios) + #:use-module (util) + #:export (with-vulgar)) + +(define-public (cls) + (display "\x1b[H") ; Move cursor to the origin + (display "\x1b[J") ; Clear everything after cursor + ) + +;;; I don't curse, I'm just vulgar. + +(define-syntax with-vulgar + (syntax-rules () + ((_ 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)) + (set! 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))) + + (tcsetattr! iattr ifd) + (tcsetattr! oattr ofd)) + thunk + (lambda () + (tcsetattr! iattr* ifd) + (tcsetattr! oattr* ofd))))))) diff --git a/module/vulgar/termios.scm b/module/vulgar/termios.scm new file mode 100644 index 00000000..aa40b6e7 --- /dev/null +++ b/module/vulgar/termios.scm @@ -0,0 +1,155 @@ +;;; Module for termios interaction from Guile, +;;; Since that for some reason isn't built in. +;; /usr/include/bits/termios.h + +(define-module (vulgar termios) + :use-module (system foreign) + :use-module (ice-9 format) + :use-module (ice-9 rdelim) + :use-module (srfi srfi-9) ; records + :use-module (util) + :export (make-termios + copy-termios + tcsetattr! tcgetattr! cfmakeraw!)) + + + +;;; Constants, TODO, auto parse these from +;; /usr/include/bits/termios.h + +(define-public ECHO 0000010) +(define-public ICANON 0000002) + +;; @var{when} values +(define-public TCSANOW 0) +(define-public TCSADRAIN 1) +(define-public TCSAFLUSH 2) + + + +;; Create the @code{#$} reader macro for creating C bindings. +;; For example +;; @example +;; #$ tcgetattr : int, * → int +;; @end example +;; would create a binding to a C function called tcgetattr, with the type +;; int, * → int, and bind it to a scheme procedure of the same name. +;; +;; Currently only links to the library stored in the variable lib, when called. +(eval-when (compile) + (read-hash-extend + #\$ (lambda (c port) + (let* ((name (string-trim-both (read-delimited ":" port))) + (input (read-delimited "→" port)) + (out (string->symbol (string-trim-both (read-line port))))) + `(define ,(string->symbol name) + (pointer->procedure + ,out (dynamic-func ,name lib) + (list + ,@(map (lambda (symb) (if (eq? symb '*) (quote '*) symb)) + (map (compose string->symbol string-trim-both) + (string-split input #\,)))))))))) + + + + +(define (empty-values struct-type) + (cond ((null? struct-type) '()) + ((list? struct-type) + (cons (empty-values (car struct-type)) + (empty-values (cdr struct-type)))) + (else 0))) + + + +(define struct-termios + (let ((cc-t uint8) + (speed-t unsigned-int) + (tcflag-t unsigned-int) + (NCCS 32)) + (list tcflag-t tcflag-t tcflag-t tcflag-t + cc-t (make-list NCCS cc-t) + speed-t speed-t))) + + +;; Representation of a termios struct. @var{ptr} should always hold a valid +;; reference to a C object, and @var{list} should hold a parsed version of the +;; same data. +(define-record-type + (%make-termios ptr list) + termios? + (ptr as-ptr) + (list as-list)) + +(define* (make-termios #:optional (data (empty-values struct-termios))) + (%make-termios (make-c-struct struct-termios data) data)) + +(define (copy-termios termios) + (let ((lst (as-list termios))) + (%make-termios (make-c-struct struct-termios lst) lst))) + +;; Sets the pointer value in termios directly. Also parses the data and sets the list. +(define (set-ptr! t v) + ((record-modifier 'ptr) t v) + ((record-modifier 'list) t (parse-c-struct v struct-termios))) + +;; Sets the list value in termios directly. Also creates a C struct of the data +;; and stores that. +(define (set-list! t v) + ((record-modifier 'list) t v) + ((record-modifier 'ptr) t (make-c-struct struct-termios v))) + +;; TODO {i,o}speed should be looked up in a table. +;; TODO bit fields should display what their fields mean +((@ (srfi srfi-9 gnu) set-record-type-printer!) + + (lambda (t p) + (format p "#" + (iflag t) (oflag t) (cflag t) (lflag t) (line t) (ispeed t) (ospeed t) + (map integer->char (filter (negate zero?) (cc t)))))) + + + +;; Macro for creating accessor bindings for slots in a list, which are wrapped +;; inside a record. Called exactly once below. +(define-macro (create-bindings! . symbols) + `(begin ,@(map-each + (lambda (symb i) + `(define-public ,symb + (make-procedure-with-setter + (lambda (t) (list-ref (as-list t) ,i)) + (lambda (t v) (let ((lst (as-list t))) + (list-set! lst ,i v) + (set-list! t lst)))))) + symbols))) + +(create-bindings! ; accessors + iflag oflag cflag lflag line cc ispeed ospeed) + + + +;; TODO this should possibly use unwind guards +(define (with-ptr termios proc) + (let ((ptr (as-ptr termios))) + (let ((ret (proc ptr))) + (set-ptr! termios ptr) + ret))) + + + +(define-once lib (dynamic-link)) + +#$ tcsetattr : int, int, * → int +(define* (tcsetattr! termios #:optional + (port (current-input-port)) + (when TCSANOW)) + (with-ptr termios (lambda (ptr) (tcsetattr (port->fdes port) when ptr)))) + + +#$ tcgetattr : int, * → int +(define* (tcgetattr! termios #:optional (port (current-input-port))) + (with-ptr termios (lambda (ptr) (tcgetattr (port->fdes port) ptr)))) + +#$ cfmakeraw : * → int +(define* (cfmakeraw! termios) + (with-ptr termios cfmakeraw)) diff --git a/module/vulgar/util.scm b/module/vulgar/util.scm new file mode 100644 index 00000000..8be97378 --- /dev/null +++ b/module/vulgar/util.scm @@ -0,0 +1,46 @@ +(define-module (vulgar util) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-60) + #:use-module (util) + #:use-module (ice-9 popen) + #:export (line ctrl color-escape)) + +(define* (line #:optional (width 64)) + (display (make-string width #\_)) + (newline)) + +(define (ctrl char) + (integer->char (bitwise-and #b00011111 (char->integer char)))) + +(define-public (display-calendar-header! date) + (let* ((day (number->string (date-day date))) + (month (number->string (date-month date))) + (year (number->string (date-year date)))) + ;; BSD cal only supports setting highlighted day explicitly for + ;; testing the functionality. This seems to at least give me + ;; an (almost) working display, albeit ugly. + (if (file-exists? "/usr/bin/ncal") + (system* "ncal" "-3" "-H" (format #f "~a-~a-~a" + year month day) + month year) + (system* "cal" "-3" day month year)))) + +(define (color-escape n) + (cond ((not n) "") + ((char=? #\# (string-ref n 0)) + (let* ((str (string-drop n 1)) + (rs (substring str 0 2)) + (gs (substring str 2 4)) + (bs (substring str 4 6))) + (format #f "\x1b[38;2;~a;~a;~am" + (string->number rs 16) + (string->number gs 16) + (string->number bs 16)))))) + + +(define-public (get-terminal-size) + (let* (((rpipe . wpipe) (pipe))) + (system (format #f "stty size > /proc/~s/fd/~s" + (getpid) (port->fdes wpipe))) + (values (read rpipe) + (read rpipe)))) -- cgit v1.2.3