#lang racket/base
;; For legal info, see file "info.rkt".

(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))
        ;; TODO: Do we actually need to turn off buffering?
        (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)))
  ;; TODO: Set the port fields of the struct to #f?
  (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")))

;; (define (call-with-charterm proc #:tty (tty #f))
;;   (let* ((tty (cleanse-path tty))
;;          (ct  (open-charterm #:tty tty #:current? #f)))
;;     (dynamic-wind
;;       void
;;       (lambda ()
;;         (proc ct))
;;       (lambda ()
;;         (close-charterm #:charterm ct)))))

(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)
        ;; Buffer is empty, so are buf-start and buf-end at 0?
        (if (zero? buf-end)
            (void)
            (begin (set-charterm-buf-start! ct 0)
                   (set-charterm-buf-end!   ct 0)))
        ;; Buffer is not empty, so is buf-start at 0?
        ;;
        ;; TODO: Maybe make this shift only if we need to to free N additional
        ;; bytes at the end?
        (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)
               ;; TODO: if buf is empty, then read into start 0!
               (let ((read-result (read-bytes-avail! (charterm-buf      ct)
                                                     in
                                                     (charterm-buf-end  ct)
                                                     (charterm-buf-size ct))))
                 (if (zero? read-result)
                     ;; TODO: If there's a timeout, subtract from it?
                     (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)
    ;; TODO: Implement timeout better, by checking clock and doing
    ;; sync/timeout, or by setting timer.
    (let loop ((timeout-seconds timeout-seconds))
      (if (= (charterm-buf-end ct) (charterm-buf-size ct))
          (begin
            ;; TODO: Make this an exception instead of #f?
            #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)
                                   ;; TODO: Audit and test some of this buffer
                                   ;; code here and elsewhere.
                                   (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)
  ;; TODO: make it replace unprintable and non-ascii characters with "?".  Even newlines, tabs, etc?
  ;;
  ;; TODO: Do we want buffering?
  (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))
              ;; TODO: Get rid of this allocation.
              (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)
  ;; TODO: Do we want buffering?
  (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)))))))

;; (provide/contract with error-checks on 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)))
  ;; TODO: Have a #:style argument?  Or #:background argument?
  (%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))
  ;; TODO: Maybe make this shift decision smarter -- compile the key tree ahead
  ;; of time so we know the max depth, and then we know exactly the max space
  ;; we will need for this call to charterm-read-key.
  (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)
                                ;; We have more subtree to search.
                                (if (or (< probe-start buf-end)
                                        (and (< buf-end buf-size)
                                             (%charterm:read-into-buf/timeout ct 0.5)))
                                    ;; We have at least one more byte, so recurse.
                                    (loop code-or-subtree
                                          (+ 1 probe-start)
                                          (bytes-ref buf probe-start))
                                    ;; We have hit timeout or end of buffer, so
                                    ;; just accept the original byte.
                                    #f)
                                ;; We found our key code, so consume the input and return the value.
                                (begin (set-charterm-buf-start! ct probe-start)
                                       code-or-subtree)))))
                    (else #f)))
            ;; We didn't find a key code, so return the initial byte as a char.
            (if (= 27 b1)
                'escape
                (integer->char b1)))
        ;; Got a timeout, so return #f.
        #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))

;; TODO: once we've finalized "%charterm:key-decoding-tree", expose it as a
;; parameter.  before we expose it, we might want to provide a way to define
;; arbitrary delay-disambiguated keys.  so, for example, instead of the node
;; for 27 being (27 . ALIST), it would be (27 escape ALIST).  There are some
;; ctrl/shift arrow combinations that send the same thing as some other
;; ctrl/shifts, but with one extra byte.
(define %charterm:key-decoding-tree
  ;; Note: Keep 91 top of the list under 27, so that it searches faster with
  ;; assv.
  '((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))) ; also shift-f1
                          (52  . ((36  . shift-f12)
                                  (94  . ctrl-f12)
                                  (126 . f12))) ; also shift-f2
                          (53  . ((126 . shift-f3)))
                          (54  . ((126 . shift-f4)))
                          (56  . ((126 . shift-f5)))
                          (57  . ((36  . shift-menu)
                                  (94  . ctrl-menu)
                                  (126 . menu))) ; also shift-f6
                          (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)))
           ;; Non-91 (non-"[") bytes.
           (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)
           ))
    ;; Non-ESC:
    (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)
  ;; Note: Commented-out debugging code:
  ;;
  ;; (and #t
  ;;      (begin (charterm-normal)
  ;;             (charterm-cursor (+ (%charterm:demo-input-x     di)
  ;;                                   (%charterm:demo-input-width di)
  ;;                                   1)
  ;;                                (%charterm:demo-input-y di))
  ;;             (charterm-display #" cursor: "
  ;;                               (%charterm:demo-input-cursor di)
  ;;                               #" used: "
  ;;                               (%charterm:demo-input-used di))
  ;;             (charterm-clear-line-right)))
  (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)))
          ;; TODO: test beginning/end of buffer, of used, of width
          (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))))
             ;; Did screen size change?
             (if read-screen-size-changed?

                 ;; 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))
                 ;; Screen size didn't change (or we didn't check).
                 (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
                             ;; (charterm-display "Timeout.")
                             (loop-maybe-check-screen-size))))))))))))))

;; (charterm-demo)

(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."))))