#lang racket/base

(require racket/port)

(provide cook-io)

(define clear-to-eol "\033[2K")
(define kill-line (string-append "\r" clear-to-eol))

(struct buffer (chars consume-next-linefeed?) #:transparent)

(define (buffer-empty? b)
  (null? (buffer-chars b)))

(define (buffer-adjust b new-chars)
  (struct-copy buffer b
	       [chars new-chars]
	       [consume-next-linefeed? #f]))

(define (buffer-contents b)
  (list->string (reverse (buffer-chars b))))

(define (update-buffer b key prompt k-eof k-complete k-ongoing)
  (case key
    ((#\backspace #\rubout) ;; backspace = ^H = code 8; delete = code 127
     (if (buffer-empty? b)
	 (k-ongoing b "")
	 (k-ongoing (buffer-adjust b (cdr (buffer-chars b))) "\b \b")))
    ((#\return) (k-complete (buffer-contents b) (buffer '() #t)))
    ((#\newline) (if (buffer-consume-next-linefeed? b)
		     (k-ongoing (struct-copy buffer b [consume-next-linefeed? #f]) "")
		     (k-complete (buffer-contents b) (buffer '() #f))))
    ((#\page) (k-ongoing b (string-append kill-line prompt (buffer-contents b))))
    ((#\004) ;; control-D, UNIX EOF
     (if (buffer-empty? b)
	 (k-eof)
	 (k-ongoing b "")))
    ((#\033) ;; escape
     (k-ongoing (buffer '() #f) (string-append kill-line prompt)))
    (else (if (char-iso-control? key)
	      (k-ongoing b "")
	      (k-ongoing (buffer-adjust b (cons key (buffer-chars b))) (string key))))))

(define (cook-io raw-in raw-out prompt)
  (define-values (cooked-in cooked-out) (make-pipe))
  (define (close-ports)
    (close-output-port cooked-out) ;; signal to our reader that we're not sending more
    (close-input-port raw-in)) ;; signal to upstream that we are done reading
  (thread
   (lambda ()
     (define input-buffer (make-bytes 4096))
     (let loop ((b (buffer '() #f)))
       (if (port-closed? cooked-in)
	   ;; The ultimate reader of our cooked output has closed
	   ;; their input port. We are therefore done.
	   (close-ports)
	   ;; TODO: remove polling for port-closed when we get port-closed-evt
	   (let ((count (sync/timeout 0.5 (read-bytes-avail!-evt input-buffer raw-in))))
	     (cond
	      ((eof-object? count) ;; end-of-file on input
	       (close-ports))
	      ((eq? count #f) ;; timeout - poll to see if cooked-out has been closed
	       (loop b))
	      (else ;; a number - count of bytes read
	       (let process-bytes ((i 0) (b b))
		 (if (>= i count)
		     (loop b)
		     (update-buffer b (integer->char (bytes-ref input-buffer i)) prompt
				    close-ports
				    (lambda (line new-b)
				      (with-handlers ((exn:fail? void)) ;; ignore write errors
					(write-string "\r\n" raw-out))
				      (write-string line cooked-out)
				      (newline cooked-out)
				      (process-bytes (+ i 1) new-b))
				    (lambda (new-b feedback)
				      (with-handlers ((exn:fail? void)) ;; ignore write errors
					(write-string feedback raw-out))
				      (process-bytes (+ i 1) new-b))))))))))))
  (values cooked-in (cook-output raw-out)))

(define (cook-output raw-out)
  (define-values (cooked-in cooked-out) (make-pipe))
  (thread
   (lambda ()
     (define buffer (make-bytes 4096))
     (let loop ()
       (define count (read-bytes-avail! buffer cooked-in))
       (if (eof-object? count)
	   (begin (close-input-port cooked-in)
		  (close-output-port raw-out))
	   (let ((raw-data (regexp-replace* #"\n" (subbytes buffer 0 count) #"\r\n")))
	     (write-bytes raw-data raw-out)
	     (loop))))))
  cooked-out)