- added output-filtering to interact
- based implementation on a functional interface
This commit is contained in:
frese
parent
c966d7d3d2
commit
3428c7a94d
|
|
@ -1,81 +1,95 @@
|
||||||
(define-syntax interact-clause-test
|
;; (interact* task [input-filter output-filter])
|
||||||
(syntax-rules (filter eof)
|
;;
|
||||||
((interact-clause-test char break) #t)
|
|
||||||
((interact-clause-test eof break (eof body ...) clause2 ...)
|
|
||||||
(begin body ...))
|
|
||||||
((interact-clause-test eof break clause1 clause2 ...)
|
|
||||||
(interact-clause-test eof break clause2 ...))
|
|
||||||
((interact-clause-test char break (eof body ...) clause2 ...)
|
|
||||||
(interact-clause-test char break clause2 ...))
|
|
||||||
((interact-clause-test char break (filter filter-proc) clause2 ...)
|
|
||||||
(and (filter-proc char break)
|
|
||||||
(interact-clause-test char break clause2 ...)))
|
|
||||||
((interact-clause-test char break (test-char k body ...) clause2 ...)
|
|
||||||
(if (eq? char test-char)
|
|
||||||
(and (let ((k break)) body ...)
|
|
||||||
(interact-clause-test char break clause2 ...))
|
|
||||||
(interact-clause-test char break clause2 ...)))))
|
|
||||||
|
|
||||||
;;; Allow user to interact with program (sometimes there's just no other way)
|
(define (interact* task . args)
|
||||||
;;; (interact task) simply switches the user into interact mode with the task.
|
(let-optionals args ((input-filter (lambda (k x) x))
|
||||||
;;;
|
(output-filter (lambda (k x) x)))
|
||||||
;;; (interact task clause ...) filters the input. The clause can either be a
|
(let ((ivec (make-vector 2))
|
||||||
;;; character clause (character continuation-variable exp ...) or a filter
|
(ivec0 (current-input-port))
|
||||||
;;; clause (filter proc). A character clause matches the character given,
|
(ivec1 (task:in task))
|
||||||
;;; links the continuation variable to the continuation out of the
|
(out0 (current-output-port))
|
||||||
;;; interaction, and runs the expressions. A filter clause runs the given
|
(out1 (task:out task)))
|
||||||
;;; filter-function with two arguments: the character entered and the
|
(call-with-current-continuation
|
||||||
;;; continuation out of the interaction. In both cases, if the filter returns
|
(lambda (k)
|
||||||
;;; true, the expression falls through. If the expression falls through to
|
(with-errno-handler
|
||||||
;;; the bottom, the character is printed. Note that the interaction will
|
((e p) ((errno/io) #f)) ;; TODO: eof in input/output
|
||||||
;;; continue anyway, unless the continuation was explicitly called.
|
(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))))))))
|
||||||
|
|
||||||
|
(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)))))
|
||||||
|
|
||||||
|
;; 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.
|
||||||
|
|
||||||
|
(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 ...)))))
|
||||||
|
|
||||||
|
(define-syntax interact-output-clauses
|
||||||
|
(syntax-rules (filter eof)
|
||||||
|
((interact-output-clauses break char)
|
||||||
|
#t)
|
||||||
|
((interact-output-clauses break char clause ...)
|
||||||
|
#t)))
|
||||||
|
|
||||||
(define-syntax interact
|
(define-syntax interact
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
((interact task)
|
||||||
;; If there is just one argument, simply enable transfer.
|
(interact* task))
|
||||||
((interact with)
|
((interact task clause ...)
|
||||||
(call-with-current-continuation
|
(interact/char* task
|
||||||
(lambda (break)
|
(lambda (k c)
|
||||||
(let ((ivec (make-vector 2))
|
(interact-input-clauses k c clause ...))
|
||||||
(ivec0 (current-input-port))
|
(lambda (k c)
|
||||||
(ivec1 (task:in with)))
|
(interact-output-clauses k c clause ...))))))
|
||||||
(with-errno-handler ((e p) ((errno/io) #f))
|
|
||||||
(let lp ()
|
|
||||||
(vector-set! ivec 0 ivec0)
|
|
||||||
(vector-set! ivec 1 ivec1)
|
|
||||||
(select! ivec '#() '#())
|
|
||||||
(if (char-ready? ivec0)
|
|
||||||
(write-string (read-string/partial 256 ivec0)
|
|
||||||
(task:out with)))
|
|
||||||
(if (char-ready? ivec1)
|
|
||||||
(write-string (read-string/partial 256 ivec1)))
|
|
||||||
(lp)))))))
|
|
||||||
|
|
||||||
;; If there is more than one argument,
|
|
||||||
;;enable transfer and allow escape keys.
|
|
||||||
((interact with clauses ...)
|
|
||||||
(call-with-current-continuation
|
|
||||||
(lambda (break)
|
|
||||||
(let ((ivec (make-vector 2))
|
|
||||||
(ivec0 (current-input-port))
|
|
||||||
(ivec1 (task:in with)))
|
|
||||||
(with-errno-handler ((e p)
|
|
||||||
((errno/io)
|
|
||||||
(interact-clause-test eof #f clauses ...)))
|
|
||||||
(let lp ()
|
|
||||||
(vector-set! ivec 0 ivec0)
|
|
||||||
(vector-set! ivec 1 ivec1)
|
|
||||||
(select! ivec '#() '#())
|
|
||||||
(if (char-ready? (current-input-port))
|
|
||||||
(for-each (lambda (transfer)
|
|
||||||
;; Test for indicated escape keys.
|
|
||||||
(and (interact-clause-test transfer break
|
|
||||||
clauses ...)
|
|
||||||
;; Only write if all clauses "fell through"
|
|
||||||
(write-char transfer (task:out with))))
|
|
||||||
(string->list (read-string/partial 256 (current-inpu
|
|
||||||
t-port)))))
|
|
||||||
(if (char-ready? (task:in with))
|
|
||||||
(write-string (read-string/partial 256 (task:in with))))
|
|
||||||
(lp)))))))))
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue