diff --git a/scheme/interact.scm b/scheme/interact.scm index 9c0e510..49d3b7b 100644 --- a/scheme/interact.scm +++ b/scheme/interact.scm @@ -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))))))