135 lines
4.1 KiB
Scheme
135 lines
4.1 KiB
Scheme
;; 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))))))
|