Rename {terminal => vulgar}.

3 files changed, 243 insertions, 0 deletions

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 <termios>
+  (%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 <termios> 'ptr)  t v)
+  ((record-modifier <termios> '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 <termios> 'list) t v)
+  ((record-modifier <termios> '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!)
+ <termios>
+ (lambda (t p)
+   (format p "#<termios iflag=~b oflag=~b cflag=~b lflag=~b line=~d ispeed=~d ospeed=~d cc=~s>"
+           (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 <termios> 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))))