#lang racket/base
(require (for-syntax racket/base
racket/syntax)
racket/date
racket/system
(planet neil/mcfly))
(doc (section "Introduction")
(para "The "
(code "charterm")
" package provides a Racket interface for character-cell video
display terminals on Unix-like systems -- both terminal emulators like "
(hyperlink "http://en.wikipedia.org/wiki/Xterm"
(code "xterm"))
", and some older hardware terminals (even the venerable "
(hyperlink "http://en.wikipedia.org/wiki/VT100"
"DEC VT100")
"). Currently, it implements a subset of "
(code "xterm")
"'s features.")
(para "This package could be built upon to implement a status/management
console for a Racket-based server process (perhaps run from an SSH session, or
perhaps in "
(code "screen")
"), a lightweight user interface for a systems tool, a command-line
REPL, a text editor, and, most importantly, a "
(hyperlink "http://en.wikipedia.org/wiki/Rogue_%28computer_game%29"
"Rogue-like")
" application.")
(para "The "
(code "charterm")
" package does not include any native code in the Racket process,
such as through the Racket FFI or C extensions. It is implemented in pure
Racket code except for briefly calling out to "
(code "/bin/stty")
" at startup time and shutdown time.")
(para "Fun fact: ``charterm'' is short for ``Character Terminal,'' not for
``Chart? Erm...'' For doing charts, see the PLoT library by Neil Toronto."))
(doc (subsection "Demo")
(para "For a demonstration, the following command, run from a terminal, should install the "
(code "charterm")
" package (if not already installed), and run the demo:")
(commandline "racket -p neil/charterm -l racket -e \"(charterm-demo)\"")
(para "Note: Although "
(racket charterm-demo)
" includes an editable text field, as proof of concept, the current
version of "
(code "charterm")
" does not provide editable text fields as reusable functionality."))
(doc (subsection "Simple Example")
(para "Here's your first "
(code "charterm")
" program:")
(RACKETBLOCK
(UNSYNTAX (code "#lang racket/base"))
(require (planet neil/charterm:1))
(with-charterm
(charterm-clear-screen)
(charterm-cursor 10 5)
(charterm-display "Hello, ")
(charterm-bold)
(charterm-display "you")
(charterm-normal)
(charterm-display ".")
(charterm-cursor 1 1)
(charterm-display "Press a key...")
(let ((key (charterm-read-key)))
(charterm-cursor 1 1)
(charterm-clear-line)
(printf "You pressed: ~S\r\n" key))))
(para "Now you're living the dream of the '70s."))
(doc (section "Interface"))
(doc (subsection (code "charterm") " Object"))
(doc (defproc (charterm? (x any/c))
boolean?
(para "Predicate for whether or not "
(var x)
" is a "
(racket charterm)
".")))
(provide charterm?)
(define-struct charterm
(tty in out buf-size buf buf-start buf-end)
#:mutable)
(doc (subsection "Opening and Closing"))
(doc (defparam current-charterm ct (or/c #f charterm?)
(para "This parameter provides the default "
(racket charterm)
" for most of the other procedures. It is usually set automatically by "
(racket call-with-charterm)
", "
(racket with-charterm)
", "
(racket open-charterm)
", and "
(racket close-charterm)
".")))
(provide current-charterm)
(define current-charterm (make-parameter #f))
(doc (defproc (open-charterm
(#:tty tty (or/c #f path-string?) #f)
(#:current? current? boolean? #t))
charterm?
(para "Returns an open "
(racket charterm)
" object, by opening I/O ports on the terminal device at "
(racket tty)
" (or, if "
(racket #f)
", file "
(filepath "/dev/tty")
"), and setting raw mode and disabling echo (via "
(filepath "/bin/stty")
"). If "
(racket current?)
" is true, the "
(racket current-charterm)
" parameter is also set to this object.")))
(provide open-charterm)
(define (open-charterm #:tty (tty #f)
#:current? (current? #t))
(let ((tty (cleanse-path (or tty "/dev/tty"))))
(or (system* "/bin/stty"
"-F"
(path->string tty)
"raw"
"-echo")
(error 'open-charterm
"stty failed"))
(with-handlers ((exn:fail? (lambda (e)
(with-handlers ((exn:fail? void))
(system* "/bin/stty"
"-F"
(path->string tty)
"sane"))
(raise e))))
(let*-values (((in out) (open-input-output-file tty
#:exists 'update))
((buf-size) 2048))
(file-stream-buffer-mode in 'none)
(file-stream-buffer-mode out 'none)
(let ((ct (make-charterm tty in out buf-size (make-bytes buf-size) 0 0)))
(and current?
(current-charterm ct))
ct)))))
(doc (defproc (close-charterm (#:charterm ct charterm? (current-charterm)))
void?
(para "Closes "
(racket ct)
" by closing the I/O ports, and undoing "
(racket open-charterm)
"'s changes via "
(filepath "/bin/stty")
". If "
(racket current-charterm)
" is set to "
(racket ct)
", then that parameter will be changed to "
(racket #f)
" for good measure. You might wish to use "
(racket with-charterm)
" instead of worrying about calling "
(racket close-charterm)
" directly.")
(para "Note: If you exit your Racket process without properly closing the "
(racket charterm)
", your terminal may be left in a crazy state. You can fix it with
the command:")
(commandline "stty sane")
(para "If only ex-lovers could be fixed as easily as ex-processes.")))
(provide close-charterm)
(define (close-charterm #:charterm (ct (current-charterm)))
(with-handlers ((exn:fail? void)) (close-input-port (charterm-in ct)))
(with-handlers ((exn:fail? void)) (close-output-port (charterm-out ct)))
(if (with-handlers ((exn:fail? (lambda (e) #f)))
(system* "/bin/stty"
"-F"
(path->string (charterm-tty ct))
"cooked"
"echo"))
(if (eq? ct (current-charterm))
(current-charterm #f)
(void))
(error 'close-charterm
"stty failed")))
(doc (defform (with-charterm expr? ...))
(para "Opens a "
(racket charterm)
" and evaluates the body expressions in sequence with "
(racket current-charterm)
" set appropriately. When control jumps out of the body, in a
manner of speaking, the "
(racket charterm)
" is closed."))
(provide with-charterm)
(define-syntax (with-charterm stx)
(syntax-case stx ()
((_ BODY0 BODYn ...)
#'(let ((ct #f))
(dynamic-wind
(lambda ()
(set! ct (open-charterm #:current? #t)))
(lambda ()
BODY0 BODYn ...)
(lambda ()
(close-charterm #:charterm ct)
(set! ct #f)))))))
(doc (subsection "Information"))
(doc (defproc (charterm-screen-size (#:charterm ct charterm? (current-charterm)))
(values (or/c #f exact-nonnegative-integer?)
(or/c #f exact-nonnegative-integer?))
(para "Attempts to get the screen size, in character columns and rows.
If unable to get a value, then "
(racket #f)
" is returned for the value.")
(para "If you find this returning ("
(racket #f)
", "
(racket #f)
"), then (80, 24) might be a good fallback.")))
(provide charterm-screen-size)
(define (charterm-screen-size #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[19t")
(cond ((%charterm:read-regexp-response ct #rx#"\e\\[9;([0-9]+);([0-9]+)t")
=> (lambda (m)
(values (%charterm:bytes-ascii->nonnegative-integer (list-ref m 1))
(%charterm:bytes-ascii->nonnegative-integer (list-ref m 0)))))
(else (values #f #f))))
(doc (subsection "Video"))
(define (%charterm:shift-buf ct)
(let ((buf-start (charterm-buf-start ct))
(buf-end (charterm-buf-end ct)))
(if (= buf-start buf-end)
(if (zero? buf-end)
(void)
(begin (set-charterm-buf-start! ct 0)
(set-charterm-buf-end! ct 0)))
(if (zero? buf-start)
(void)
(let ((buf (charterm-buf ct)))
(bytes-copy! buf 0 buf buf-start buf-end)
(set-charterm-buf-start! ct 0)
(set-charterm-buf-end! ct (- buf-end buf-start)))))))
(define (%charterm:read-into-buf/timeout ct timeout)
(let ((in (charterm-in ct)))
(let loop ()
(let ((sync-result (sync/timeout/enable-break timeout in)))
(cond ((not sync-result) #f)
((eq? sync-result in)
(let ((read-result (read-bytes-avail! (charterm-buf ct)
in
(charterm-buf-end ct)
(charterm-buf-size ct))))
(if (zero? read-result)
(loop)
(begin (set-charterm-buf-end! ct (+ (charterm-buf-end ct) read-result))
read-result))))
(else (error '%charterm:read-into-buf/timeout
"*DEBUG* sync returned ~S"
sync-result)))))))
(define (%charterm:read-regexp-response ct rx #:timeout-seconds (timeout-seconds 1.0))
(let ((in (charterm-in ct)))
(%charterm:shift-buf ct)
(let loop ((timeout-seconds timeout-seconds))
(if (= (charterm-buf-end ct) (charterm-buf-size ct))
(begin
#f)
(begin (or (let ((buf (charterm-buf ct))
(buf-start (charterm-buf-start ct))
(buf-end (charterm-buf-end ct)))
(cond ((regexp-match-positions rx
buf
buf-start
buf-end)
=> (lambda (m)
(let ((match-start (caar m))
(match-end (cdar m)))
(if (= match-start buf-start)
(set-charterm-buf-start! ct match-end)
(if (= match-end buf-end)
(set-charterm-buf-end! ct match-start)
(begin (bytes-copy! buf
match-start
buf
match-end
buf-end)
(set-charterm-buf-end! ct
(+ match-start
(- buf-end
match-end)))))))
(map (lambda (pos)
(subbytes buf (car pos) (cdr pos)))
(cdr m))))
(else #f)))
(if (%charterm:read-into-buf/timeout ct timeout-seconds)
(loop timeout-seconds)
#f
)))))))
(define (%charterm:bytes-ascii->nonnegative-integer bstr)
(let ((bstr-len (bytes-length bstr)))
(let loop ((i 0)
(result 0))
(if (= i bstr-len)
result
(let* ((b (bytes-ref bstr i))
(b-num (- b 48)))
(if (<= 0 b-num 9)
(loop (+ 1 i)
(+ (* 10 result) b-num))
(error '%charterm:bytes-ascii->nonnegative-integer
"invalid byte ~S"
b)))))))
(doc (subsubsection "Cursor"))
(doc (defproc (charterm-cursor (x exact-positive-integer?)
(y exact-positive-integer?)
(#:charterm ct charterm? (current-charterm)))
void?
(para "Positions the cursor at column "
(racket x)
", row "
(racket y)
", with the upper-left character cell being (1, 1).")))
(provide charterm-cursor)
(define (charterm-cursor x y #:charterm (ct (current-charterm)))
(%charterm:position ct x y))
(doc (defproc (charterm-newline (#:charterm ct charterm? (current-charterm)))
void?
(para "Sends a newline to the terminal. This is typically a CR-LF
sequence.")))
(provide charterm-newline)
(define (charterm-newline #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\r\n"))
(doc (subsubsection "Displaying"))
(define %charterm:err-byte 63)
(doc (defproc (charterm-display
(#:charterm ct charterm? (current-charterm))
(#:width width (or/c #f exact-positive-integer?) #f)
(#:pad pad (or/c 'width boolean?) 'width)
(#:truncate truncate (or/c 'width boolean?) 'width)
( arg any/c) ...)
void?
(para "Displays each "
(racket arg)
" on the terminal, as if formatted by "
(racket display)
", with the exception that unprintable or non-ASCII characters might not be displayed. (The exact behavior of what is permitted is expected to change in a later version of "
(code "charterm")
", so avoid trying to send your own control sequences or using newlines, making assumptions about non-ASCII, etc.)")
(para "If "
(racket width)
" is a number, then "
(racket pad)
" and "
(racket truncate)
" specify whether or not to pad with spaces or truncate the output, respectively, to "
(racket width)
" characters. When "
(racket pad)
" or "
(racket width)
" is "
(racket 'width)
", that is a convenience meaning ``true if, and only if, width is not "
(racket #f)
".''")))
(provide charterm-display)
(define (charterm-display #:charterm (ct (current-charterm))
#:width (width #f)
#:pad (pad 'width)
#:truncate (truncate 'width)
. args)
(let ((out (charterm-out ct))
(pad (if (eq? 'width pad) (if width #t #f) pad))
(truncate (if (eq? 'width truncate) (if width #t #f) truncate)))
(and pad (not width) (error 'charterm-display "#:pad cannot be true if #:width is not"))
(and truncate (not width) (error 'charterm-display "#:truncate cannot be true if #:width is not"))
(let loop ((args args)
(remaining-width (or width 0)))
(if (null? args)
(if (and pad (> remaining-width 0))
(begin (%charterm:write-bytes ct (make-bytes remaining-width 32))
(void))
(void))
(let* ((arg (car args))
(bytes (cond ((bytes? arg)
arg)
((string? arg)
(string->bytes/latin-1 arg
%charterm:err-byte
0
(if truncate
(min (string-length arg)
remaining-width)
(string-length arg))))
((number? arg)
(string->bytes/latin-1 (number->string arg)
%charterm:err-byte))
(else (let ((arg (format "~A" arg)))
(string->bytes/latin-1 arg
%charterm:err-byte
0
(if truncate
(min (string-length arg)
remaining-width)
(string-length arg)))))))
(remaining-width (- remaining-width (bytes-length bytes))))
(cond ((or (not truncate) (> remaining-width 0))
(%charterm:write-bytes ct bytes)
(loop (cdr args)
remaining-width))
((zero? remaining-width)
(%charterm:write-bytes ct bytes)
(void))
(else (%charterm:write-subbytes ct bytes 0 (+ (bytes-length bytes)
remaining-width))
(void))))))))
(define (%charterm:send-code ct . args)
(let ((out (charterm-out ct)))
(let loop ((args args))
(if (null? args)
(void)
(let ((arg (car args)))
(cond ((bytes? arg)
(write-bytes arg out))
((string? arg)
(write-string arg out))
((integer? arg)
(display (inexact->exact arg) out))
((pair? arg)
(loop (car arg))
(loop (cdr arg)))
(else (error '%charterm:send-code
"don't know how to send ~S"
arg)))
(loop (cdr args)))))))
(define (%charterm:position ct x y)
(if (and (= 1 x) (= 1 y))
(%charterm:write-bytes ct #"\e[;H")
(%charterm:send-code ct #"\e[" y #";" x #"H")))
(doc (subsubsection "Video Attributes"))
(doc (defproc*
(((charterm-normal (#:charterm ct charterm? (current-charterm))) void?)
((charterm-inverse (#:charterm ct charterm? (current-charterm))) void?)
((charterm-bold (#:charterm ct charterm? (current-charterm))) void?)
((charterm-underline (#:charterm ct charterm? (current-charterm))) void?)
((charterm-blink (#:charterm ct charterm? (current-charterm))) void?))
(para "Sets the "
(deftech "video attributes")
" for subsequent writes to the terminal. In this version of "
(code "charterm")
", each is mutually-exclusive, so, for example, setting "
(italic "bold")
" clears "
(italic "inverse")
". Note that not all terminals support all of these.")))
(provide charterm-normal)
(define (charterm-normal #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[m"))
(provide charterm-inverse)
(define (charterm-inverse #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[7m"))
(provide charterm-bold)
(define (charterm-bold #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[1m"))
(provide charterm-underline)
(define (charterm-underline #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[4m"))
(provide charterm-blink)
(define (charterm-blink #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[5m"))
(doc (subsubsection "Clearing"))
(doc (defproc (charterm-clear-screen (#:charterm ct charterm? (current-charterm)))
void?
(para "Clears the screen, including first setting the video attributes to
normal, and positioning the cursor at (1, 1).")))
(provide charterm-clear-screen)
(define (charterm-clear-screen #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[m\e[2J\e[;H"))
(doc (defproc*
(((charterm-clear-line (#:charterm ct charterm? (current-charterm))) void?)
((charterm-clear-line-left (#:charterm ct charterm? (current-charterm))) void?)
((charterm-clear-line-right (#:charterm ct charterm? (current-charterm))) void?))
(para "Clears text from the line with the cursor, or part of the line with the cursor.")))
(provide charterm-clear-line)
(define (charterm-clear-line #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[2K"))
(provide charterm-clear-line-left)
(define (charterm-clear-line-left #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[1K"))
(provide charterm-clear-line-right)
(define (charterm-clear-line-right #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\e[K"))
(doc (subsubsection "Line Insert and Delete"))
(doc (defproc (charterm-insert-line (count exact-positive-integer? 1)
(#:charterm ct charterm? (current-charterm)))
void?
(para "Inserts "
(racket count)
" blank lines at cursor. Note that not all terminals support
this.")))
(provide charterm-insert-line)
(define (charterm-insert-line (count 1) #:charterm (ct (current-charterm)))
(%charterm:send-code ct #"\e[" count "L"))
(doc (defproc (charterm-delete-line (count exact-positive-integer? 1)
(#:charterm ct charterm? (current-charterm)))
void?
(para "Deletes "
(racket count)
" blank lines at cursor. Note that not all terminals support
this.")))
(provide charterm-delete-line)
(define (charterm-delete-line (count 1) #:charterm (ct (current-charterm)))
(%charterm:send-code ct #"\e[" count "M"))
(doc (defproc (charterm-bell (#:charterm ct charterm? (current-charterm)))
void?
(para "Rings the terminal bell. This bell ringing might manifest as a
beep, a flash of the screen, or nothing.")))
(provide charterm-bell)
(define (charterm-bell #:charterm (ct (current-charterm)))
(%charterm:write-bytes ct #"\007"))
(doc (subsection "Keyboard"))
(doc (defproc (charterm-byte-ready? (#:charterm ct charterm? (current-charterm)))
boolean?
(para "Returns true/false for whether at least one byte is ready for
reading (either in a buffer or on the port) from "
(racket ct)
". Note that, since some keys are encoded as multiple bytes, just
because this procedure returns true doesn't mean that "
(racket charterm-read-key)
" won't block temporarily because it sees part of a potential
multiple-byte key encoding.")))
(provide charterm-byte-ready?)
(define (charterm-byte-ready? #:charterm (ct (current-charterm)))
(or (> (charterm-buf-end ct) (charterm-buf-start ct))
(byte-ready? (charterm-in ct))))
(doc (defproc (charterm-read-key
(#:charterm ct charterm? (current-charterm))
(#:timeout timeout (or/c #f positive?) #f))
(or #f char? symbol?)
(para "Reads a key from "
(racket ct)
", blocking indefinitely or until sometime after "
(racket timeout)
" seconds has been reached, if "
(racket timeout)
" is non-"
(racket #f)
". If timeout is reached, "
(racket #f)
" is returned.")
(para "Many keys are returned as characters, especially ones that
correspond to printable characters. For example, the unshifted ``q'' key is
returned as character "
(racket #\q)
". Other keys are returned as symbols, such as "
(racket 'return)
", "
(racket 'esc)
", "
(racket 'f1)
", "
(racket 'shift-f12)
", "
(racket 'right)
", and many others.")
(para "Since some keys are sent as ambiguous sequences, "
(racket charterm-read-key)
" employs separate timeouts internally, such as to disambuate
the "
(bold "Esc")
" key (byte sequence 27) from what on some terminals would be
the "
(bold "F10")
" key (bytes sequence 27, 91, 50, 49, 126).")))
(provide charterm-read-key)
(define (charterm-read-key #:charterm (ct (current-charterm))
#:timeout (timeout #f))
(and (< (- (charterm-buf-size ct)
(charterm-buf-start ct))
10)
(%charterm:shift-buf ct))
(let ((buf (charterm-buf ct))
(buf-start (charterm-buf-start ct))
(buf-end (charterm-buf-end ct))
(buf-size (charterm-buf-size ct))
(b1 (%charterm:read-byte/timeout ct timeout)))
(if b1
(or (let loop ((tree %charterm:key-decoding-tree)
(probe-start (+ 1 buf-start))
(b b1))
(cond ((assv b tree)
=> (lambda (pair)
(let ((code-or-subtree (cdr pair)))
(if (pair? code-or-subtree)
(if (or (< probe-start buf-end)
(and (< buf-end buf-size)
(%charterm:read-into-buf/timeout ct 0.5)))
(loop code-or-subtree
(+ 1 probe-start)
(bytes-ref buf probe-start))
#f)
(begin (set-charterm-buf-start! ct probe-start)
code-or-subtree)))))
(else #f)))
(if (= 27 b1)
'escape
(integer->char b1)))
#f)))
(define (%charterm:write-bytes ct bstr)
(write-bytes bstr (charterm-out ct)))
(define (%charterm:write-subbytes ct bstr start end)
(write-bytes bstr (charterm-out ct) start end))
(define (%charterm:read-byte/timeout ct timeout)
(let ((buf-start (charterm-buf-start ct)))
(if (or (< buf-start (charterm-buf-end ct))
(%charterm:read-into-buf/timeout ct timeout))
(begin0 (bytes-ref (charterm-buf ct) buf-start)
(set-charterm-buf-start! ct (+ 1 buf-start)))
#f)))
(define (%charterm:read-byte ct)
(%charterm:read-byte/timeout ct #f))
(define %charterm:key-decoding-tree
'((27 . ((91 . ((49 . ((49 . ((94 . ctrl-f1)
(126 . f1)))
(50 . ((94 . ctrl-f2)
(126 . f2)))
(51 . ((94 . ctrl-f3)
(126 . f3)))
(52 . ((94 . ctrl-f4)
(126 . f4)))
(53 . ((94 . ctrl-f5)
(126 . f5)))
(55 . ((94 . ctrl-f6)
(126 . f6)))
(56 . ((94 . ctrl-f7)
(126 . f7)))
(57 . ((94 . ctrl-f8)
(126 . f8)))))
(50 . ((48 . ((94 . ctrl-f9)
(126 . f9)))
(49 . ((94 . ctrl-f10)
(126 . f10)))
(51 . ((36 . shift-f11)
(126 . f11))) (52 . ((36 . shift-f12)
(94 . ctrl-f12)
(126 . f12))) (53 . ((126 . shift-f3)))
(54 . ((126 . shift-f4)))
(56 . ((126 . shift-f5)))
(57 . ((36 . shift-menu)
(94 . ctrl-menu)
(126 . menu))) (126 . insert)))
(51 . ((36 . shift-delete)
(49 . ((126 . shift-f7)))
(50 . ((126 . shift-f8)))
(51 . ((126 . shift-f9)))
(52 . ((126 . shift-f10)))
(126 . delete)))
(53 . ((126 . pgup)))
(54 . ((126 . pgdn)))
(55 . ((36 . shift-home)
(94 . ctrl-home)
(126 . home)))
(56 . ((36 . shift-end)
(94 . ctrl-end)
(126 . end)))
(65 . up)
(66 . down)
(67 . right)
(68 . left)
(90 . shift-tab)
(97 . shift-up)
(98 . shift-down)
(99 . shift-right)
(100 . shift-left)))
(45 . alt-minus)
(48 . alt-0)
(49 . alt-1)
(50 . alt-2)
(51 . alt-3)
(52 . alt-4)
(53 . alt-5)
(54 . alt-6)
(55 . alt-7)
(56 . alt-8)
(57 . alt-9)
(65 . alt-shift-a)
(66 . alt-shift-b)
(67 . alt-shift-c)
(68 . alt-shift-d)
(69 . alt-shift-e)
(70 . alt-shift-f)
(71 . alt-shift-g)
(72 . alt-shift-h)
(73 . alt-shift-i)
(74 . alt-shift-j)
(75 . alt-shift-k)
(76 . alt-shift-l)
(77 . alt-shift-m)
(78 . alt-shift-n)
(79 . alt-shift-o)
(80 . alt-shift-p)
(81 . alt-shift-q)
(82 . alt-shift-r)
(83 . alt-shift-s)
(84 . alt-shift-t)
(85 . alt-shift-u)
(86 . alt-shift-v)
(87 . alt-shift-w)
(88 . alt-shift-x)
(89 . alt-shift-y)
(90 . alt-shift-z)
(97 . alt-a)
(98 . alt-b)
(99 . alt-c)
(100 . alt-d)
(101 . alt-e)
(102 . alt-f)
(103 . alt-g)
(104 . alt-h)
(105 . alt-i)
(106 . alt-j)
(107 . alt-k)
(108 . alt-l)
(109 . alt-m)
(110 . alt-n)
(111 . alt-o)
(112 . alt-p)
(113 . alt-q)
(114 . alt-r)
(115 . alt-s)
(116 . alt-t)
(117 . alt-u)
(118 . alt-v)
(119 . alt-w)
(120 . alt-x)
(121 . alt-y)
(122 . alt-z)
))
(0 . nul)
(1 . ctrl-a)
(2 . ctrl-b)
(3 . ctrl-c)
(4 . ctrl-d)
(5 . ctrl-e)
(6 . ctrl-f)
(7 . ctrl-g)
(8 . ctrl-h)
(9 . tab)
(10 . ctrl-j)
(11 . ctrl-k)
(12 . ctrl-l)
(13 . enter)
(14 . ctrl-n)
(15 . ctrl-o)
(16 . ctrl-p)
(17 . ctrl-q)
(18 . ctrl-r)
(19 . ctrl-s)
(20 . ctrl-t)
(21 . ctrl-u)
(22 . ctrl-v)
(23 . ctrl-w)
(24 . ctrl-x)
(25 . ctrl-y)
(26 . ctrl-z)
(127 . backspace)))
(doc (section "Misc."))
(define (%charterm:string-pad-or-truncate str width)
(let ((len (string-length str)))
(cond ((= len width) str)
((< len width) (string-append str (make-string (- width len) #\space)))
(else (substring str 0 width)))))
(define (%charterm:bytes-pad-or-truncate bstr width)
(let ((len (bytes-length bstr)))
(cond ((= len width) bstr)
((< len width)
(let ((new-bstr (make-bytes width 32)))
(bytes-copy! new-bstr 0 bstr)
new-bstr))
(else (subbytes bstr 0 width)))))
(define-struct %charterm:demo-input
(x y width bytes used cursor)
#:mutable)
(define (%charterm:make-demo-input x y width bstr)
(let ((new-bstr (%charterm:bytes-pad-or-truncate bstr width))
(used (min (bytes-length bstr) width)))
(make-%charterm:demo-input x
y
width
new-bstr
used
used)))
(define (%charterm:demo-input-redraw di)
(charterm-cursor (%charterm:demo-input-x di)
(%charterm:demo-input-y di))
(charterm-normal)
(charterm-underline)
(charterm-display (%charterm:demo-input-bytes di)
#:width (%charterm:demo-input-width di))
(charterm-normal))
(define (%charterm:demo-input-put-cursor di)
(charterm-cursor (+ (%charterm:demo-input-x di)
(%charterm:demo-input-cursor di))
(%charterm:demo-input-y di)))
(define (%charterm:demo-input-cursor-left di)
(let ((cursor (%charterm:demo-input-cursor di)))
(if (zero? cursor)
(begin (charterm-bell)
(%charterm:demo-input-put-cursor di))
(begin (set-%charterm:demo-input-cursor! di (- cursor 1))
(%charterm:demo-input-put-cursor di)))))
(define (%charterm:demo-input-cursor-right di)
(let ((cursor (%charterm:demo-input-cursor di)))
(if (= cursor (%charterm:demo-input-used di))
(begin (charterm-bell)
(%charterm:demo-input-put-cursor di))
(begin (set-%charterm:demo-input-cursor! di (+ cursor 1))
(%charterm:demo-input-put-cursor di)))))
(define (%charterm:demo-input-backspace di)
(let ((cursor (%charterm:demo-input-cursor di)))
(if (zero? cursor)
(begin (charterm-bell)
(%charterm:demo-input-put-cursor di))
(let ((bstr (%charterm:demo-input-bytes di))
(used (%charterm:demo-input-used di)))
(bytes-copy! bstr (- cursor 1) bstr cursor used)
(bytes-set! bstr (- used 1) 32)
(set-%charterm:demo-input-used! di (- used 1))
(set-%charterm:demo-input-cursor! di (- cursor 1))
(%charterm:demo-input-redraw di)
(%charterm:demo-input-put-cursor di)))))
(define (%charterm:demo-input-delete di)
(let ((cursor (%charterm:demo-input-cursor di))
(used (%charterm:demo-input-used di)))
(if (= cursor used)
(begin (charterm-bell)
(%charterm:demo-input-put-cursor di))
(let ((bstr (%charterm:demo-input-bytes di)))
(or (= cursor used)
(bytes-copy! bstr cursor bstr (+ 1 cursor) used))
(bytes-set! bstr (- used 1) 32)
(set-%charterm:demo-input-used! di (- used 1))
(%charterm:demo-input-redraw di)
(%charterm:demo-input-put-cursor di)))))
(define (%charterm:demo-input-insert-byte di new-byte)
(let ((used (%charterm:demo-input-used di))
(width (%charterm:demo-input-width di)))
(if (= used width)
(begin (charterm-bell)
(%charterm:demo-input-put-cursor di))
(let ((bstr (%charterm:demo-input-bytes di))
(cursor (%charterm:demo-input-cursor di)))
(or (= cursor used)
(bytes-copy! bstr (+ cursor 1) bstr cursor used))
(bytes-set! bstr cursor new-byte)
(set-%charterm:demo-input-used! di (+ 1 used))
(set-%charterm:demo-input-cursor! di (+ cursor 1))
(%charterm:demo-input-redraw di)
(%charterm:demo-input-put-cursor di)))))
(doc (defproc (charterm-demo (#:tty tty (or/c #f path-string?) #f))
void?
(para "This procedure runs a demonstration program using "
(code "charterm")
". Specifically, it reports what keys you pressed, while letting
you edit a text field, and while displaying a clock. The clock is updated
roughly once per second, and is not updated during heavy keyboard input, such
as when typing fast. The demo responds to changing terminal sizes, such as
when an "
(code "xterm")
" is window is resized. It also displays the determined terminal
size, and some small tests of the "
(racket #:width)
" argument to "
(racket charterm-display)
". Exit the demo by pressing the "
(bold "Esc")
" key.")))
(provide charterm-demo)
(define (charterm-demo #:tty (tty #f))
(let ((data-row 4)
(di (%charterm:make-demo-input 10 2 18 #"Hello, world!")))
(with-charterm
(let/ec done-ec
(let loop-remember-read-screen-size ((last-read-col-count 0)
(last-read-row-count 0))
(let loop-maybe-check-screen-size ()
(let*-values (((read-col-count read-row-count)
(if (or (equal? 0 last-read-col-count)
(equal? 0 last-read-row-count)
(not (charterm-byte-ready?)))
(charterm-screen-size)
(values last-read-col-count
last-read-row-count)))
((read-screen-size? col-count row-count)
(if (and read-col-count read-row-count)
(values #t
read-col-count
read-row-count)
(values #f
(or read-col-count 80)
(or read-row-count 24))))
((read-screen-size-changed?)
(not (and (equal? read-col-count
last-read-col-count)
(equal? read-row-count
last-read-row-count))))
((clock-col)
(let ((clock-col (- col-count 8)))
(if (< clock-col 15)
#f
clock-col))))
(if read-screen-size-changed?
(begin (charterm-clear-screen)
(charterm-cursor 1 1)
(charterm-inverse)
(charterm-display (%charterm:string-pad-or-truncate " charterm-demo"
col-count))
(charterm-normal)
(charterm-cursor 1 2)
(charterm-inverse)
(charterm-display #" Input: ")
(charterm-normal)
(%charterm:demo-input-redraw di)
(charterm-cursor 1 data-row)
(charterm-display "To quit, press ")
(charterm-bold)
(charterm-display "Esc")
(charterm-normal)
(charterm-display ".")
(charterm-cursor 1 data-row)
(charterm-insert-line)
(charterm-display #"Screen size: ")
(charterm-bold)
(charterm-display col-count)
(charterm-normal)
(charterm-display #" x ")
(charterm-bold)
(charterm-display row-count)
(charterm-normal)
(or read-screen-size?
(charterm-display #" (guessing; terminal would not tell us)"))
(charterm-cursor 1 data-row)
(charterm-insert-line)
(charterm-display #"Widths:")
(for-each (lambda (bytes)
(charterm-display #" [")
(charterm-underline)
(charterm-display bytes #:width 3)
(charterm-normal)
(charterm-display #"]"))
'(#"" #"a" #"ab" #"abc" #"abcd"))
(loop-remember-read-screen-size read-col-count
read-row-count))
(begin
(and clock-col
(begin (charterm-inverse)
(charterm-cursor clock-col 1)
(charterm-display (parameterize ((date-display-format 'iso-8601))
(substring (date->string (current-date) #t)
11)))
(charterm-normal)))
(let loop-fast-next-key ()
(%charterm:demo-input-put-cursor di)
(let ((key (charterm-read-key #:timeout 1)))
(if key
(begin (charterm-cursor 1 data-row)
(charterm-insert-line)
(if (char? key)
(let ((key-num (char->integer key)))
(charterm-display #"Read key: ")
(charterm-bold)
(charterm-display (format "~S" key))
(charterm-normal)
(charterm-display #" (" key-num #")")
(if (<= 32 key-num 126)
(begin (%charterm:demo-input-insert-byte di key-num)
(loop-fast-next-key))
(loop-fast-next-key)))
(begin (charterm-display #"Read key: ")
(charterm-bold)
(charterm-display key)
(charterm-normal)
(case key
((left)
(%charterm:demo-input-cursor-left di)
(loop-fast-next-key))
((right)
(%charterm:demo-input-cursor-right di)
(loop-fast-next-key))
((backspace)
(%charterm:demo-input-backspace di)
(loop-fast-next-key))
((delete)
(%charterm:demo-input-delete di)
(loop-fast-next-key))
((escape)
(charterm-clear-screen)
(charterm-display "charterm-demo has been quit.")
(charterm-newline)
(done-ec))
(else (loop-fast-next-key))))))
(begin
(loop-maybe-check-screen-size))))))))))))))
(doc (section "Known Issues")
(itemlist
(item "Currently only implemented to work on Unix-like systems like
GNU/Linux.")
(item "Only supports ASCII characters. UTF-8, for terminal emulators
that support it, would be nice.")
(item "More controls for terminal features can be added.")
(item "Add other ways to detect terminal size.")
(item "Need to look more at low-level TTY issues and buffering,
especially since "
(code "screen")
" is noticeably sluggish on key responses with "
(racket charterm-demo)
".")
(item "Expose the character-decoding mini-language as a configurable
option. Perhaps wait until we implement timeout-based disambiguation at
arbitrary points in the the DFA rather than just at the top. Also, might be
better to resolve multi-byte characters first, in case that affects the
mini-language.")
(item "Possibly make a "
(racket charterm)
" object usable as a Racket event.")
(item "Implement text input controls, either as part of this library or
another, using "
(racket charterm-demo)
" as a starting point.")))
(doc history
(#:planet 1:0 #:date "2012-06-16"
(itemlist
(item
"Initial version."))))