- reimplemented interact with expect
This commit is contained in:
frese
parent
7642842a3a
commit
c7f21da61a
|
|
@ -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)))
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-errno-handler
|
||||
((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))))
|
||||
(lp))))))))
|
||||
;; 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))
|
||||
str))
|
||||
(lambda (k str)
|
||||
(if output-filter
|
||||
(let ((chars (filter (lambda (c) (output-filter k c))
|
||||
(string->list str))))
|
||||
(list->string chars))
|
||||
str)))))
|
||||
;; 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)
|
||||
#t)
|
||||
((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)
|
||||
#t)
|
||||
((interact-output-clauses break char clause ...)
|
||||
#t)))
|
||||
(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)
|
||||
(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))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue