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/terminal/escape.scm | 42 ------------ module/terminal/termios.scm | 155 -------------------------------------------- module/terminal/util.scm | 46 ------------- 3 files changed, 243 deletions(-) delete mode 100644 module/terminal/escape.scm delete mode 100644 module/terminal/termios.scm delete mode 100644 module/terminal/util.scm (limited to 'module/terminal') diff --git a/module/terminal/escape.scm b/module/terminal/escape.scm deleted file mode 100644 index a16df594..00000000 --- a/module/terminal/escape.scm +++ /dev/null @@ -1,42 +0,0 @@ -;;; Module for terminal (ANSI) escape codes. - -(define-module (terminal escape) - #:use-module (srfi srfi-60) - #:use-module (terminal 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/terminal/termios.scm b/module/terminal/termios.scm deleted file mode 100644 index 77e6ecf0..00000000 --- a/module/terminal/termios.scm +++ /dev/null @@ -1,155 +0,0 @@ -;;; Module for termios interaction from Guile, -;;; Since that for some reason isn't built in. -;; /usr/include/bits/termios.h - -(define-module (terminal 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/terminal/util.scm b/module/terminal/util.scm deleted file mode 100644 index f4d60fda..00000000 --- a/module/terminal/util.scm +++ /dev/null @@ -1,46 +0,0 @@ -(define-module (terminal 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