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/output/info.scm | 2 +- module/output/terminal.scm | 4 +- module/terminal/escape.scm | 42 ------------ module/terminal/termios.scm | 155 -------------------------------------------- module/terminal/util.scm | 46 ------------- module/vulgar/escape.scm | 42 ++++++++++++ module/vulgar/termios.scm | 155 ++++++++++++++++++++++++++++++++++++++++++++ module/vulgar/util.scm | 46 +++++++++++++ 8 files changed, 246 insertions(+), 246 deletions(-) delete mode 100644 module/terminal/escape.scm delete mode 100644 module/terminal/termios.scm delete mode 100644 module/terminal/util.scm create mode 100644 module/vulgar/escape.scm create mode 100644 module/vulgar/termios.scm create mode 100644 module/vulgar/util.scm diff --git a/module/output/info.scm b/module/output/info.scm index 376b125f..cc976472 100644 --- a/module/output/info.scm +++ b/module/output/info.scm @@ -4,7 +4,7 @@ (use-modules (ice-9 getopt-long) (vcomponent) (vcomponent output) - (terminal util) + (vulgar util) (srfi srfi-1)) (define-public (info-main calendars events args) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index bf0b25e5..1225f335 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -8,8 +8,8 @@ #:use-module (srfi srfi-41) #:use-module (srfi srfi-41 util) #:use-module (util) - #:use-module (terminal escape) - #:use-module (terminal util) + #:use-module (vulgar escape) + #:use-module (vulgar util) #:use-module (vcomponent output) #:use-module (vcomponent group) 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)))) 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