scsh-expect/scheme/interact.scm

;; TODO: interpreter?

;; The pattern eof introduces an action that is executed upon end-
;; of-file.  A separate eof pattern may also follow the -output flag
;; in which case it is matched if an eof is detected while writing
;; output.  The default eof action is "return", so that interact
;; simply returns upon any EOF.

;; The pattern timeout introduces a timeout (in seconds) and action
;; that is executed after no characters have been read for a given
;; time.

;; The -echo flag sends characters that match the following pattern
;; back to the process that generated them as each character is read.
;; This may be useful when the user needs to see feedback from
;; partially typed patterns.

;; The -nobuffer flag sends characters that match the following pat-
;; tern on to the output process as characters are read.

(define-record-type :eof-pattern
  (make-eof-pattern)
  eof-pattern?)

(define eof-pattern (make-eof-pattern))

(define (interact* task re-flags-handler-list timeout-handler)
  (let* ((user-in (current-input-port))
	 (user-out (current-output-port))
	 (user-task (user-task))
	 (tty-before (tty-info user-in))
	 (init-tty (lambda ()
		     (set! tty-before (tty-info user-in))
		     (modify-tty (lambda (ti) (raw (echo-off ti))) user-in)))
	 (reset-tty (lambda ()
		      (set-tty-info/now user-in tty-before))))
    ;; TODO: if no tty??
    (init-tty)
    (call-with-current-continuation
     (lambda (k)
       (let ((conv
	      (lambda (loop)
		(lambda (re-flags-handler)
		  (let* ((re (car re-flags-handler))
			 (re (cond
			      ((string? re) (rx ,re))
			      ((char? re) (rx ,(make-string 1 re)))
			      (else re)))
			 (flags (cadr re-flags-handler))
			 (handler (caddr re-flags-handler))
			 (before (lambda ()
				   (if (memq 'reset flags) (reset-tty))))
			 (after (lambda ()
				  (if (memq 'reset flags) (init-tty)))))
		    (cond
		     ((eq? eof-pattern re)
		      (list 'eof
			    (lambda ()
			      (before)
			      (handler k #f)
			      (after))))
		     (else
		      (list 'match
			    (lambda () re)
			    (lambda (m)
			      (before)
			      (handler k m)
			      (after)
			      (loop))))))))))
	 (let-values (((outputs inputs)
		       (partition (lambda (re-flag-handler)
				    (memq 'output (second re-flag-handler)))
				  re-flags-handler-list)))
	   (let ((output-else-rx (else-rx (map car outputs)))
		 (input-else-rx (else-rx (map car inputs))))
	     (let loop ()
	       (let ((timeout (if timeout-handler
				  (list (cons 'timeout (car timeout-handler))
					(cons 'on-timeout
					      (lambda ()
						((cdr timeout-handler) k)
						(loop))))
				  '((timeout . #f)))))
		 (expect* timeout
			  (cons user-task
				(cons (list 'match (lambda () input-else-rx)
					    (lambda (m)
					      (write-string (match:substring m)
							    (task:out task))
					      (loop)))
				      (map (conv loop) inputs)))
			  (cons task
				(cons (list 'match (lambda () output-else-rx)
					    (lambda (m)
					      (write-string (match:substring m)
							    (task:out user-task)
							    )
					      (loop)))
				      (map (conv loop) outputs)))))))))))
    (reset-tty)))


;; returns a pattern, that matches anything but the given patterns
(define (else-rx patterns)
  ;; only character-patterns supported
  (if (null? patterns)
      (rx any)
      (let ((p (car patterns))
	    (rest (cdr patterns)))
	(cond
	 ((char? (car patterns))
	  (rx (- ,(else-rx rest) ,p)))
	 (else (error "Only character-patterns are supported."))))))

(define-syntax interact-clauses
  (syntax-rules (timeout)
    ((interact-clauses) (cons #f '()))
    ((interact-clauses (timeout secs handler) rest ...)
     (let ((r (interact-clauses rest ...)))
       (cons (cons secs handler)
	     (cdr r))))
    ((interact-clauses (rx (flag ...) (cont match mvar ...) body ...) rest ...)
     (let ((r (interact-clauses rest ...)))
       (cons (car r)
	     (cons (list rx `(flag ...) (lambda (cont match)
					  (let-match match (mvar ...)
						     body ...)))
		   (cdr r)))))))

(define-syntax interact
  (syntax-rules ()
    ((interact task iclause ...)
     (let ((r (interact-clauses iclause ...)))
       (interact* task (cdr r) (car r))))))