- reimplemented interact with expect

This commit is contained in:
frese 2004-08-24 13:22:33 +00:00
parent 7642842a3a
commit c7f21da61a
1 changed files with 126 additions and 87 deletions

View File

@ -1,95 +1,134 @@
;; (interact* task [input-filter output-filter])
;; TODO: interpreter?
(define (interact* task . args)
(let-optionals args ((input-filter (lambda (k x) x))
(output-filter (lambda (k x) x)))
(let ((ivec (make-vector 2))
(ivec0 (current-input-port))
(ivec1 (task:in task))
(out0 (current-output-port))
(out1 (task:out task)))
(lambda (k)
((e p) ((errno/io) #f)) ;; TODO: eof in input/output
(let lp ()
(vector-set! ivec 0 ivec0)
(vector-set! ivec 1 ivec1)
(select! ivec '#() '#())
(if (char-ready? ivec0)
(let ((str (input-filter k (read-string/partial 256 ivec0))))
(if str (write-string str out1))))
(if (char-ready? ivec1)
(let ((str (output-filter k (read-string/partial 256 ivec1))))
(if str (write-string str out0))))
;; 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.
(define (interact/char* task . args)
(let-optionals args ((input-filter #f)
(output-filter #f))
(interact* task
(lambda (k str)
(if input-filter
;; TODO: does this preserve correct order?
(let ((chars (filter (lambda (c) (input-filter k c))
(string->list str))))
(list->string chars))
(lambda (k str)
(if output-filter
(let ((chars (filter (lambda (c) (output-filter k c))
(string->list str))))
(list->string chars))
;; The pattern timeout introduces a timeout (in seconds) and action
;; that is executed after no characters have been read for a given
;; time.
;; syntax
;;;; Allow user to interact with program (sometimes there's just no other way)
;;;; (interact task) simply switches the user into interact mode with the task.
;;;; (interact task clause ...) filters the input. The clause can either be a
;;;; character clause (character continuation-variable exp ...) or a filter
;;;; clause (filter proc). A character clause matches the character given,
;;;; links the continuation variable to the continuation out of the
;;;; interaction, and runs the expressions. A filter clause runs the given
;;;; filter-function with two arguments: the character entered and the
;;;; continuation out of the interaction. In both cases, if the filter returns
;;;; true, the expression falls through. If the expression falls through to
;;;; the bottom, the character is printed. Note that the interaction will
;;;; continue anyway, unless the continuation was explicitly called.
;; 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.
(define-syntax interact-input-clauses
(syntax-rules (filter eof)
((interact-input-clauses break char)
((interact-input-clauses break char (eof k body ...) clause2 ...)
(if (eof-object? char)
(let ((k break))
(begin body ...))
(interact-input-clauses break char clause2 ...)))
((interact-input-clauses break char (test-char k body ...) clause2 ...)
(if (eq? char test-char)
(let ((k break))
(begin body ...))
(interact-input-clauses break char clause2 ...)))
((interact-input-clauses break char (filter proc) clause2 ...)
(and (filter break char)
(interact-input-clauses break char clause2 ...)))))
;; The -nobuffer flag sends characters that match the following pat-
;; tern on to the output process as characters are read.
(define-syntax interact-output-clauses
(syntax-rules (filter eof)
((interact-output-clauses break char)
((interact-output-clauses break char clause ...)
(define-record-type :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??
(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)))))
((eq? eof-pattern re)
(list 'eof
(lambda ()
(handler k #f)
(list 'match
(lambda () re)
(lambda (m)
(handler k m)
(let-values (((outputs inputs)
(partition (lambda (re-flag-handler)
(memq 'output (second re-flag-handler)))
(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)
'((timeout . #f)))))
(expect* timeout
(cons user-task
(cons (list 'match (lambda () input-else-rx)
(lambda (m)
(write-string (match:substring m)
(task:out task))
(map (conv loop) inputs)))
(cons task
(cons (list 'match (lambda () output-else-rx)
(lambda (m)
(write-string (match:substring m)
(task:out user-task)
(map (conv loop) outputs)))))))))))
;; 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)))
((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)
(interact* task))
((interact task clause ...)
(interact/char* task
(lambda (k c)
(interact-input-clauses k c clause ...))
(lambda (k c)
(interact-output-clauses k c clause ...))))))
((interact task iclause ...)
(let ((r (interact-clauses iclause ...)))
(interact* task (cdr r) (car r))))))