- reimplemented interact with expect

scheme/interact.scm

@@ -1,95 +1,134 @@
-;; (interact* task [input-filter output-filter])
+;; TODO: interpreter?
-;; 
 
-(define (interact* task . args)
+;; The pattern eof introduces an action that is executed upon end-
-  (let-optionals args ((input-filter (lambda (k x) x))
+;; of-file.  A separate eof pattern may also follow the -output flag
-		       (output-filter (lambda (k x) x)))
+;; in which case it is matched if an eof is detected while writing
-     (let ((ivec (make-vector 2))
+;; output.  The default eof action is "return", so that interact
-	   (ivec0 (current-input-port))
+;; simply returns upon any EOF.
-	   (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))))))))
 
-(define (interact/char* task . args)
+;; The pattern timeout introduces a timeout (in seconds) and action
-  (let-optionals args ((input-filter #f)
+;; that is executed after no characters have been read for a given
-		       (output-filter #f))
+;; time.
-    (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
+;; The -echo flag sends characters that match the following pattern
-;;;; Allow user to interact with program (sometimes there's just no other way)
+;; back to the process that generated them as each character is read.
-;;;; (interact task) simply switches the user into interact mode with the task.
+;; This may be useful when the user needs to see feedback from
-;;;; 
+;; partially typed patterns.
-;;;; (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
+;; The -nobuffer flag sends characters that match the following pat-
-  (syntax-rules (filter eof)
+;; tern on to the output process as characters are read.
-    ((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
+(define-record-type :eof-pattern
-  (syntax-rules (filter eof)
+  (make-eof-pattern)
-    ((interact-output-clauses break char)
+  eof-pattern?)
-     #t)
+
-    ((interact-output-clauses break char clause ...)
+(define eof-pattern (make-eof-pattern))
-     #t)))
+
+(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 iclause ...)
-     (interact* task))
+     (let ((r (interact-clauses iclause ...)))
-    ((interact task clause ...)
+       (interact* task (cdr r) (car r))))))
-     (interact/char* task
-		     (lambda (k c)
-		       (interact-input-clauses k c clause ...))
-		     (lambda (k c)
-		       (interact-output-clauses k c clause ...))))))