136 lines
4.2 KiB

;; 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
(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 eof)
((interact-clauses) (cons #f '()))
((interact-clauses (timeout secs handler) rest ...)
(let ((r (interact-clauses rest ...)))
(cons (cons secs handler)
(cdr r))))
((interact-clauses (eof (flag ...) body ...) rest ...)
(interact-clauses (eof-pattern (flag ...) (cont ignore) body ...)
rest ...))
((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))))))