Add terminal control library with ANSI escape codes (#47)
ober
cfd2cee6d6c98e9792026d10d13230e487629c89
new file mode 100644 --- /dev/null +++ b/lib/std/misc/terminal.sls @@ -0,0 +1,288 @@ +#!chezscheme +;;; (std misc terminal) — ANSI terminal control +;;; +;;; Cursor, screen, text styling, colors, raw mode, and alternate screen. +;;; All escape sequences are written to current-output-port. +;;; +;;; (cursor-up 3) ; move cursor up 3 lines +;;; (bold "hello") ; => "\e[1mhello\e[0m" +;;; (fg-color 'red "text") ; => "\e[31mtext\e[0m" +;;; (with-raw-mode (lambda () ...)) + +(library (std misc terminal) + (export + ;; Cursor control + cursor-up cursor-down cursor-forward cursor-back + cursor-position cursor-save cursor-restore + cursor-hide cursor-show + + ;; Screen control + clear-screen clear-line clear-to-end clear-to-beginning + + ;; Text styling + bold dim italic underline blink reverse-video reset-style + + ;; Colors + fg-color bg-color + + ;; Terminal dimensions + terminal-width terminal-height + + ;; Raw mode + with-raw-mode + + ;; Alternate screen + with-alternate-screen) + + (import (chezscheme)) + + ;; ========== Escape sequence helpers ========== + + (define esc "\x1b;") + + (define (csi . parts) + (apply string-append esc "[" parts)) + + (define (emit . strings) + (for-each (lambda (s) (display s (current-output-port))) strings) + (flush-output-port (current-output-port))) + + ;; ========== Cursor control ========== + + (define cursor-up + (case-lambda + [() (emit (csi "1" "A"))] + [(n) (emit (csi (number->string n) "A"))])) + + (define cursor-down + (case-lambda + [() (emit (csi "1" "B"))] + [(n) (emit (csi (number->string n) "B"))])) + + (define cursor-forward + (case-lambda + [() (emit (csi "1" "C"))] + [(n) (emit (csi (number->string n) "C"))])) + + (define cursor-back + (case-lambda + [() (emit (csi "1" "D"))] + [(n) (emit (csi (number->string n) "D"))])) + + (define (cursor-position row col) + (emit (csi (number->string row) ";" (number->string col) "H"))) + + (define (cursor-save) + (emit (csi "s"))) + + (define (cursor-restore) + (emit (csi "u"))) + + (define (cursor-hide) + (emit (csi "?" "25" "l"))) + + (define (cursor-show) + (emit (csi "?" "25" "h"))) + + ;; ========== Screen control ========== + + (define (clear-screen) + (emit (csi "2" "J"))) + + (define (clear-line) + (emit (csi "2" "K"))) + + (define (clear-to-end) + (emit (csi "0" "K"))) + + (define (clear-to-beginning) + (emit (csi "1" "K"))) + + ;; ========== Text styling ========== + ;; + ;; Each styling function can be called two ways: + ;; (bold) => emits the SGR code (turn on bold) + ;; (bold "text") => returns styled string with reset appended + + (define (sgr-code n) + (csi (number->string n) "m")) + + (define (make-style-fn code) + (case-lambda + [() (emit (sgr-code code))] + [(text) + (string-append (sgr-code code) text (sgr-code 0))])) + + (define bold (make-style-fn 1)) + (define dim (make-style-fn 2)) + (define italic (make-style-fn 3)) + (define underline (make-style-fn 4)) + (define blink (make-style-fn 5)) + (define reverse-video (make-style-fn 7)) + + (define (reset-style) + (emit (sgr-code 0))) + + ;; ========== Colors ========== + ;; + ;; Named colors: black red green yellow blue magenta cyan white + ;; 256-color: pass an integer 0-255 + ;; + ;; (fg-color 'red) => emits foreground red + ;; (fg-color 'red "text") => returns string with fg red + text + reset + ;; (fg-color 196) => emits 256-color foreground + ;; (fg-color 196 "text") => returns string with 256-color + text + reset + + (define color-table + '((black . 0) + (red . 1) + (green . 2) + (yellow . 3) + (blue . 4) + (magenta . 5) + (cyan . 6) + (white . 7))) + + (define (color-name->code name) + (let ([pair (assq name color-table)]) + (if pair + (cdr pair) + (error 'color "unknown color name" name)))) + + (define (fg-escape color) + (cond + [(symbol? color) + (sgr-code (+ 30 (color-name->code color)))] + [(and (integer? color) (<= 0 color 255)) + (csi "38;5;" (number->string color) "m")] + [else (error 'fg-color "expected color name or 0-255" color)])) + + (define (bg-escape color) + (cond + [(symbol? color) + (sgr-code (+ 40 (color-name->code color)))] + [(and (integer? color) (<= 0 color 255)) + (csi "48;5;" (number->string color) "m")] + [else (error 'bg-color "expected color name or 0-255" color)])) + + (define fg-color + (case-lambda + [(color) (emit (fg-escape color))] + [(color text) + (string-append (fg-escape color) text (sgr-code 0))])) + + (define bg-color + (case-lambda + [(color) (emit (bg-escape color))] + [(color text) + (string-append (bg-escape color) text (sgr-code 0))])) + + ;; ========== Terminal dimensions ========== + + (define (read-all port) + (let lp ((chunks '())) + (let ((buf (get-string-n port 4096))) + (if (eof-object? buf) + (if (null? chunks) + "" + (apply string-append (reverse chunks))) + (lp (cons buf chunks)))))) + + (define (string-trim s) + ;; Trim leading and trailing whitespace + (let* ([len (string-length s)] + [start (let lp ([i 0]) + (if (and (< i len) (char-whitespace? (string-ref s i))) + (lp (+ i 1)) + i))] + [end (let lp ([i len]) + (if (and (> i start) (char-whitespace? (string-ref s (- i 1)))) + (lp (- i 1)) + i))]) + (substring s start end))) + + (define (stty-size) + ;; Returns (values rows cols) from `stty size`, or #f #f on failure. + (guard (exn [#t (values #f #f)]) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports "stty size </dev/tty 2>/dev/null" + 'line (native-transcoder))]) + (close-port to-stdin) + (let* ([output (string-trim (read-all from-stdout))] + [_ (close-port from-stdout)] + [_ (close-port from-stderr)]) + (if (= (string-length output) 0) + (values #f #f) + (let ([parts (string-split output #\space)]) + (if (>= (length parts) 2) + (values (string->number (car parts)) + (string->number (cadr parts))) + (values #f #f)))))))) + + (define (string-split s ch) + ;; Split string s on character ch, skipping empty parts + (let ([len (string-length s)]) + (let lp ([i 0] [start 0] [acc '()]) + (cond + [(= i len) + (reverse (if (> i start) + (cons (substring s start i) acc) + acc))] + [(char=? (string-ref s i) ch) + (lp (+ i 1) (+ i 1) + (if (> i start) + (cons (substring s start i) acc) + acc))] + [else (lp (+ i 1) start acc)])))) + + (define (terminal-width) + (or (let ([v (getenv "COLUMNS")]) + (and v (string->number v))) + (let-values ([(rows cols) (stty-size)]) + (or cols 80)))) + + (define (terminal-height) + (or (let ([v (getenv "LINES")]) + (and v (string->number v))) + (let-values ([(rows cols) (stty-size)]) + (or rows 24)))) + + ;; ========== Raw mode ========== + + (define (with-raw-mode thunk) + ;; Save terminal settings, switch to raw mode, run thunk, restore. + ;; Uses stty since we don't want to depend on FFI/ioctl. + (let ([saved #f]) + (dynamic-wind + (lambda () + ;; Save current terminal settings + (guard (exn [#t (void)]) + (let-values ([(to from err pid) + (open-process-ports "stty -g </dev/tty" + 'line (native-transcoder))]) + (close-port to) + (set! saved (string-trim (read-all from))) + (close-port from) + (close-port err))) + ;; Switch to raw mode + (guard (exn [#t (void)]) + (system "stty raw -echo </dev/tty 2>/dev/null"))) + thunk + (lambda () + ;; Restore saved settings + (when (and saved (> (string-length saved) 0)) + (guard (exn [#t (void)]) + (system (string-append "stty " saved " </dev/tty 2>/dev/null")))))))) + + ;; ========== Alternate screen ========== + + (define (with-alternate-screen thunk) + ;; Switch to alternate screen buffer, run thunk, switch back. + (dynamic-wind + (lambda () + (emit (csi "?" "1049" "h"))) + thunk + (lambda () + (emit (csi "?" "1049" "l"))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-terminal.ss @@ -0,0 +1,350 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc terminal)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") + (display (if (message-condition? e) (condition-message e) e)) + (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +;; Helper: capture output to a string by redirecting current-output-port +(define (capture-output thunk) + (let ([p (open-output-string)]) + (parameterize ([current-output-port p]) + (thunk)) + (get-output-string p))) + +(define esc "\x1b;") +(define (csi . parts) + (apply string-append esc "[" parts)) + +(define (string-contains haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let lp ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (lp (+ i 1))])))) + +(display "--- (std misc terminal) tests ---\n") + +;; ========== Cursor control tests ========== + +(test "cursor-up default" + (lambda () + (assert-equal (capture-output (lambda () (cursor-up))) + (csi "1" "A") + "cursor-up default"))) + +(test "cursor-up n" + (lambda () + (assert-equal (capture-output (lambda () (cursor-up 5))) + (csi "5" "A") + "cursor-up 5"))) + +(test "cursor-down default" + (lambda () + (assert-equal (capture-output (lambda () (cursor-down))) + (csi "1" "B") + "cursor-down default"))) + +(test "cursor-down n" + (lambda () + (assert-equal (capture-output (lambda () (cursor-down 3))) + (csi "3" "B") + "cursor-down 3"))) + +(test "cursor-forward default" + (lambda () + (assert-equal (capture-output (lambda () (cursor-forward))) + (csi "1" "C") + "cursor-forward default"))) + +(test "cursor-forward n" + (lambda () + (assert-equal (capture-output (lambda () (cursor-forward 10))) + (csi "10" "C") + "cursor-forward 10"))) + +(test "cursor-back default" + (lambda () + (assert-equal (capture-output (lambda () (cursor-back))) + (csi "1" "D") + "cursor-back default"))) + +(test "cursor-back n" + (lambda () + (assert-equal (capture-output (lambda () (cursor-back 7))) + (csi "7" "D") + "cursor-back 7"))) + +(test "cursor-position" + (lambda () + (assert-equal (capture-output (lambda () (cursor-position 10 20))) + (csi "10" ";" "20" "H") + "cursor-position 10 20"))) + +(test "cursor-save" + (lambda () + (assert-equal (capture-output cursor-save) + (csi "s") + "cursor-save"))) + +(test "cursor-restore" + (lambda () + (assert-equal (capture-output cursor-restore) + (csi "u") + "cursor-restore"))) + +(test "cursor-hide" + (lambda () + (assert-equal (capture-output cursor-hide) + (csi "?" "25" "l") + "cursor-hide"))) + +(test "cursor-show" + (lambda () + (assert-equal (capture-output cursor-show) + (csi "?" "25" "h") + "cursor-show"))) + +;; ========== Screen control tests ========== + +(test "clear-screen" + (lambda () + (assert-equal (capture-output clear-screen) + (csi "2" "J") + "clear-screen"))) + +(test "clear-line" + (lambda () + (assert-equal (capture-output clear-line) + (csi "2" "K") + "clear-line"))) + +(test "clear-to-end" + (lambda () + (assert-equal (capture-output clear-to-end) + (csi "0" "K") + "clear-to-end"))) + +(test "clear-to-beginning" + (lambda () + (assert-equal (capture-output clear-to-beginning) + (csi "1" "K") + "clear-to-beginning"))) + +;; ========== Text styling tests ========== + +(test "bold emit" + (lambda () + (assert-equal (capture-output (lambda () (bold))) + (csi "1" "m") + "bold emit"))) + +(test "bold wrap text" + (lambda () + (assert-equal (bold "hello") + (string-append (csi "1" "m") "hello" (csi "0" "m")) + "bold wrap"))) + +(test "dim wrap text" + (lambda () + (assert-equal (dim "hello") + (string-append (csi "2" "m") "hello" (csi "0" "m")) + "dim wrap"))) + +(test "italic wrap text" + (lambda () + (assert-equal (italic "hello") + (string-append (csi "3" "m") "hello" (csi "0" "m")) + "italic wrap"))) + +(test "underline wrap text" + (lambda () + (assert-equal (underline "hello") + (string-append (csi "4" "m") "hello" (csi "0" "m")) + "underline wrap"))) + +(test "blink wrap text" + (lambda () + (assert-equal (blink "hello") + (string-append (csi "5" "m") "hello" (csi "0" "m")) + "blink wrap"))) + +(test "reverse-video wrap text" + (lambda () + (assert-equal (reverse-video "hello") + (string-append (csi "7" "m") "hello" (csi "0" "m")) + "reverse-video wrap"))) + +(test "reset-style" + (lambda () + (assert-equal (capture-output reset-style) + (csi "0" "m") + "reset-style"))) + +;; ========== Color tests ========== + +(test "fg-color named emit" + (lambda () + (assert-equal (capture-output (lambda () (fg-color 'red))) + (csi "31" "m") + "fg red emit"))) + +(test "fg-color named wrap" + (lambda () + (assert-equal (fg-color 'green "hi") + (string-append (csi "32" "m") "hi" (csi "0" "m")) + "fg green wrap"))) + +(test "fg-color all named colors" + (lambda () + (for-each + (lambda (pair) + (let ([name (car pair)] [code (cdr pair)]) + (assert-equal + (capture-output (lambda () (fg-color name))) + (csi (number->string (+ 30 code)) "m") + (format "fg ~a" name)))) + '((black . 0) (red . 1) (green . 2) (yellow . 3) + (blue . 4) (magenta . 5) (cyan . 6) (white . 7))))) + +(test "bg-color named emit" + (lambda () + (assert-equal (capture-output (lambda () (bg-color 'blue))) + (csi "44" "m") + "bg blue emit"))) + +(test "bg-color named wrap" + (lambda () + (assert-equal (bg-color 'yellow "hi") + (string-append (csi "43" "m") "hi" (csi "0" "m")) + "bg yellow wrap"))) + +(test "fg-color 256 emit" + (lambda () + (assert-equal (capture-output (lambda () (fg-color 196))) + (csi "38;5;" "196" "m") + "fg 256 emit"))) + +(test "fg-color 256 wrap" + (lambda () + (assert-equal (fg-color 42 "text") + (string-append (csi "38;5;" "42" "m") "text" (csi "0" "m")) + "fg 256 wrap"))) + +(test "bg-color 256 emit" + (lambda () + (assert-equal (capture-output (lambda () (bg-color 220))) + (csi "48;5;" "220" "m") + "bg 256 emit"))) + +(test "bg-color 256 wrap" + (lambda () + (assert-equal (bg-color 100 "text") + (string-append (csi "48;5;" "100" "m") "text" (csi "0" "m")) + "bg 256 wrap"))) + +(test "fg-color bad name errors" + (lambda () + (let ([got-error #f]) + (guard (exn [#t (set! got-error #t)]) + (fg-color 'purple)) + (assert-equal got-error #t "should error on bad color name")))) + +;; ========== Terminal dimension tests ========== + +(test "terminal-width returns integer" + (lambda () + (assert-equal (integer? (terminal-width)) #t "width is integer"))) + +(test "terminal-height returns integer" + (lambda () + (assert-equal (integer? (terminal-height)) #t "height is integer"))) + +(test "terminal-width positive" + (lambda () + (assert-equal (> (terminal-width) 0) #t "width > 0"))) + +(test "terminal-height positive" + (lambda () + (assert-equal (> (terminal-height) 0) #t "height > 0"))) + +;; ========== with-alternate-screen test ========== + +(test "with-alternate-screen emits correct sequences" + (lambda () + (let ([body-ran #f]) + (let ([output (capture-output + (lambda () + (with-alternate-screen + (lambda () + (set! body-ran #t)))))]) + (assert-equal body-ran #t "body executed") + ;; Should contain enter and exit sequences + (assert-equal + (string-contains output (csi "?" "1049" "h")) + #t + "enter alt screen") + (assert-equal + (string-contains output (csi "?" "1049" "l")) + #t + "exit alt screen"))))) + +;; ========== with-raw-mode test ========== +;; We can only test that it runs the body and doesn't crash. +;; Actual raw mode requires a real tty, which automated tests lack. + +(test "with-raw-mode runs body" + (lambda () + (let ([body-ran #f]) + (with-raw-mode (lambda () (set! body-ran #t))) + (assert-equal body-ran #t "body executed")))) + +;; ========== Composability tests ========== + +(test "nested styling" + (lambda () + ;; bold + fg-color produces correct nested escapes + (let ([result (bold (fg-color 'red "hello"))]) + (assert-equal (string? result) #t "returns string") + ;; Should contain bold open, fg red, text, reset sequences + (assert-equal (string-contains result "hello") #t "contains text")))) + +(test "multiple cursor moves captured" + (lambda () + (let ([output (capture-output + (lambda () + (cursor-up 2) + (cursor-forward 5) + (cursor-down 1)))]) + (assert-equal + output + (string-append (csi "2" "A") (csi "5" "C") (csi "1" "B")) + "sequence of moves")))) + +;; ========== Summary ========== + +(newline) +(display (format "~a/~a tests passed~%" pass-count test-count)) +(when (< pass-count test-count) + (display (format "~a tests FAILED~%" (- test-count pass-count))) + (exit 1)) +(display "All tests passed.\n")