From 1c20604f4fe76bd05d2ee54e1d922205eab376b7 Mon Sep 17 00:00:00 2001
From: eknauel <eknauel>
Date: Wed, 10 Aug 2005 18:03:59 +0000
Subject: [PATCH] Make the spectacular new command language work. At least for
 values of "work" that don't call for intensive testing.

---
 scheme/comp-cmd.scm      |  62 ++++++++++++++++++
 scheme/job.scm           | 137 +++++++++++++++++++++++++--------------
 scheme/nuit-engine.scm   |  20 +-----
 scheme/nuit-packages.scm |  37 ++++++++++-
 scheme/std-command.scm   |  85 ++++++++++++++++++------
 5 files changed, 254 insertions(+), 87 deletions(-)
 create mode 100644 scheme/comp-cmd.scm

diff --git a/scheme/comp-cmd.scm b/scheme/comp-cmd.scm
new file mode 100644
index 0000000..bf4d47d
--- /dev/null
+++ b/scheme/comp-cmd.scm
@@ -0,0 +1,62 @@
+;; compile a command line to a scsh process form
+;;
+;; ,open signals command-line-lexer command-line-parser command-line-absyn
+
+(define (compile-redirection redir)
+  (list (redirection-op redir) (redirection-dest redir)))
+
+(define (compile-command cmd)
+  `(epf
+    (,(command-executable cmd) ,@(command-args cmd))
+    ,@(map compile-redirection 
+	   (command-redirections cmd))))
+
+(define (compile-command-chain chain)
+  (let ((semicolon (string->symbol ";")))
+    (let lp ((chain chain) (pf '()))
+      (if (null? chain)
+	  pf
+	  (let ((combinator (caar chain))
+		(command (compile-command (cdar chain)))
+		(next (lambda (pf) 
+			(lp (cdr chain) pf))))
+	    (cond
+	     ((eq? combinator 'none)
+	      (next command))
+	     ((eq? combinator '|)
+	      (if (and (not (null? pf)) 
+		       (eq? (car pf) combinator))
+		  (next (append pf (list command)))
+		  (next (list '| pf command))))
+	     ((eq? combinator '&&)
+	      (next
+	       `(begin
+		  (let ((status (run ,pf)))
+		    (if (zero? status)
+			(exit (status:exit-val (run ,command)))
+			(exit (status:exit-val status)))))))
+	     ((eq? combinator '||)
+	      (next
+	       `(begin
+		  (let ((status (run ,pf)))
+		    (if (zero? status)
+			(exit 0)
+			(exit (status:exit-val (run ,command))))))))
+	     ((eq? combinator semicolon)
+	      (next 
+	       `(begin (run ,pf) 
+		       (exit (status:exit-val (run ,command))))))
+	     (else
+	      (error "Unknown combinator" combinator))))))))
+
+(define (compile-command-line cmdln)
+  (let ((pf
+	 (compile-command-chain 
+	  (cons
+	   (cons 'none (command-line-first-cmd cmdln))
+	   (command-line-combinator/cmds cmdln)))))
+    (case (command-line-job-ctrl cmdln)
+      ((&)  `(run/bg ,pf))
+      ((&*) `(run/console ,pf))
+      (else `(run/fg ,pf)))))
+
diff --git a/scheme/job.scm b/scheme/job.scm
index 86fe4c8..efbc946 100644
--- a/scheme/job.scm
+++ b/scheme/job.scm
@@ -284,61 +284,104 @@
     (thunk)
     (set-tty-info/now port settings)))
 
+;; run a job by running the program form
+
+
+;; for use in command mode (used by command-line-compiler)
+(define (run/console* s-expr)
+  (call-with-values
+      (lambda ()
+	(fork-pty-session
+	 (lambda () 
+	   (eval-s-expr s-expr))))
+    (lambda (proc pty-in pty-out tty-name)
+      (make-job-with-console
+       s-expr proc pty-in pty-out
+       (make-terminal-buffer
+	(- (result-buffer-num-cols (result-buffer)) 1)
+	(- (result-buffer-num-lines (result-buffer)) 1))))))
+
+;; for use in Scheme mode
 (define-syntax run/console
   (syntax-rules ()
-    ((_ epf)
-     (call-with-values
-	 (lambda ()
-	   (fork-pty-session
-	    (lambda ()
-	      (exec-epf epf))))
-       (lambda (proc pty-in pty-out tty-name)
-	 (make-job-with-console
-	  (quote epf) proc
-	  pty-in pty-out 
-	  (make-terminal-buffer 
-	   (- (result-buffer-num-cols (result-buffer)) 1)
-	   (- (result-buffer-num-lines (result-buffer)) 1))))))))
+    ((_ pf)
+     (run/console* (cons 'run (quote pf))))))
+
+;; for use in command mode (used by command-line-compiler)
+(define (run/fg* s-expr)
+  (debug-message "run/fg* " s-expr)
+  (save-tty-excursion
+   (current-input-port)
+   (lambda ()
+     (def-prog-mode)
+     (clear)
+     (endwin)
+     (restore-initial-tty-info! (current-input-port))
+     (drain-tty (current-output-port))
+     (obtain-lock paint-lock)
+     (let ((foreground-pgrp (tty-process-group (current-output-port)))
+	   (proc 
+	    (fork 
+	     (lambda () 
+	       (set-process-group (pid) (pid))
+	       (set-tty-process-group (current-output-port) (pid))
+	       (eval-s-expr s-expr)))))
+       (job-status (make-job-sans-console s-expr proc))
+       (set-tty-process-group (current-output-port) foreground-pgrp)
+       (display "Press any key to return to Commander S...")
+       (wait-for-key)
+       (release-lock paint-lock)))))
 
 (define-syntax run/fg
   (syntax-rules ()
     ((_ epf)
-     (save-tty-excursion
-      (current-input-port)
-      (lambda ()
-	(def-prog-mode)
-	(clear)
-	(endwin)
-	(restore-initial-tty-info! (current-input-port))
-	(drain-tty (current-output-port))
-	(obtain-lock paint-lock)
-	(let ((foreground-pgrp (tty-process-group (current-output-port)))
-	      (proc 
-	       (fork 
-		(lambda () 
-		  (set-process-group (pid) (pid))
-		  (set-tty-process-group (current-output-port) (pid))
-		  (exec-epf epf)))))
-	  (job-status (make-job-sans-console (quote epf) proc))
-	  (set-tty-process-group (current-output-port) foreground-pgrp)
-	  (display "Press any key to return to Commander S...")
-	  (wait-for-key)
-	  (release-lock paint-lock)))))))
+     (run/fg* `(run ,(quote epf))))))
 
+;; for use in command mode (used by command-line-compiler)
+(define (run/bg* s-expr)
+  (obtain-lock paint-lock)
+  (drain-tty (current-output-port))
+  (set-tty-process-group (current-output-port) (pid))
+  (let ((proc
+	 (fork
+	  (lambda ()
+	    (set-process-group (pid) (pid))
+	    (eval-s-expr s-expr)))))
+    (let ((job (make-job-sans-console (quote epf) proc)))
+      (release-lock paint-lock)
+      job)))
+
+;; for use in Scheme mode
 (define-syntax run/bg
   (syntax-rules ()
-    ((_ epf)
-     (begin
-       (obtain-lock paint-lock)
-       (drain-tty (current-output-port))
-       (set-tty-process-group (current-output-port) (pid))
-       (let ((proc
- 	      (fork
- 	       (lambda ()
-		 (set-process-group (pid) (pid))
- 		 (exec-epf epf)))))
- 	 (let ((job (make-job-sans-console (quote epf) proc)))
-	   (release-lock paint-lock)
- 	   job))))))
+    ((_ pf)
+     (run/bg* (cons 'run (quote pf))))))
+
+(define (init-evaluation-environment package)
+  (let ((structure (reify-structure package)))
+    (load-structure structure)
+    (rt-structure->environment structure)))
+
+(define *evaluation-environment* 
+  (delay (init-evaluation-environment 'nuit-eval)))
+
+(define (evaluation-environment) (force *evaluation-environment*))
+
+(define (read-sexp-from-string string)
+  (let ((string-port (open-input-string string)))
+    (read string-port)))
+
+(define (eval-string str)
+  (eval (read-sexp-from-string str)
+	(evaluation-environment)))
+;       (with-fatal-and-capturing-error-handler
+;        (lambda (condition raw-continuation continuation decline)
+; 	 raw-continuation)
+;        (lambda ()
+; 	 (eval (read-sexp-from-string exp) env))))))
+
+(define (eval-s-expr s-expr)
+  (debug-message "eval-s-expr " s-expr)
+  (eval s-expr (evaluation-environment)))
 
 ;;; EOF
\ No newline at end of file
diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm
index 077639f..9d8cd75 100644
--- a/scheme/nuit-engine.scm
+++ b/scheme/nuit-engine.scm
@@ -203,7 +203,7 @@
 (define (eval-command-in-scheme-mode command-line)
   (let ((viewer
 	 (find/init-plugin-for-result
-	  (eval-expression command-line))))
+	  (eval-string command-line))))
     (let* ((tokens (split-command-line command-line))
 	   (command (car tokens))
 	   (args (cdr tokens))
@@ -588,24 +588,6 @@
 			(+ (buffer-pos-line (command-buffer)) 1))
   (set-buffer-pos-col! (command-buffer) 2))
 
-(define (init-evaluation-environment package)
-  (let ((structure (reify-structure package)))
-    (load-structure structure)
-    (rt-structure->environment structure)))
-
-(define (read-sexp-from-string string)
-  (let ((string-port (open-input-string string)))
-    (read string-port)))
-
-(define eval-expression
-  (let ((env (init-evaluation-environment 'nuit-eval)))
-    (lambda (exp)
-      (eval (read-sexp-from-string exp) env))))
-;       (with-fatal-and-capturing-error-handler
-;        (lambda (condition raw-continuation continuation decline)
-; 	 raw-continuation)
-;        (lambda ()
-; 	 (eval (read-sexp-from-string exp) env))))))
 
 (define (determine-plugin-by-type result)
   (find (lambda (r)
diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm
index 6918702..acef519 100644
--- a/scheme/nuit-packages.scm
+++ b/scheme/nuit-packages.scm
@@ -233,8 +233,13 @@
 	srfi-37
 	sorting
 
+	command-line-lexer
+	command-line-parser
+	command-line-absyn
+	command-line-compiler
 	joblist
 	jobs
+	run-jobs-internals
 	layout
         fs-object
 	pps
@@ -376,8 +381,9 @@
    srfi-1
 
    terminal-buffer
-   jobs
    run-jobs
+   run-jobs-internals
+   jobs
    focus-table
    fs-object
    pps)
@@ -525,6 +531,14 @@
    (run/fg :syntax)
    (run/bg :syntax)))
 
+(define-interface run-jobs-internals-interface
+  (export
+   eval-string
+   eval-s-expr
+   run/console*
+   run/fg*
+   run/bg*))
+
 (define-interface joblist-interface
   (export running-jobs
 	  ready-jobs
@@ -535,18 +549,21 @@
 
 (define-structures ((jobs	job-interface)
 		    (run-jobs   run-jobs-interface)
+		    (run-jobs-internals run-jobs-internals-interface)
 		    (joblist	joblist-interface))
   (open (modify scheme-with-scsh 
 		(hide receive select))
 	define-record-types
 	threads
 	srfi-1
+	srfi-6
 	signals
 	locks
 
 	rendezvous
 	rendezvous-channels
 	rendezvous-placeholders
+	rt-modules
 
 	initial-tty
 	ncurses
@@ -618,6 +635,21 @@
 	signals 
 	handle)
   (files cmdline))
+
+;;; command line compiler
+
+(define-interface command-line-compiler-interface
+  (export compile-command-line))
+
+(define-structure command-line-compiler 
+    command-line-compiler-interface
+  (open scheme
+	signals
+
+	command-line-lexer
+	command-line-parser
+	command-line-absyn)
+  (files comp-cmd))
    
 ;;; nuit 
 
@@ -640,7 +672,6 @@
 	srfi-13
 	debugging
 	inspect-exception
-	rt-modules
 	tty-debug
 	threads
 	rendezvous
@@ -668,6 +699,8 @@
 	completion-sets
 	select-list
 	jobs
+	run-jobs
+	run-jobs-internals
 	joblist
 	;; the following modules are plugins
 	joblist-viewer
diff --git a/scheme/std-command.scm b/scheme/std-command.scm
index ae6e51c..acb98d3 100644
--- a/scheme/std-command.scm
+++ b/scheme/std-command.scm
@@ -1,6 +1,8 @@
 (define (standard-command-plugin-completer command args)
   #f)
 
+;; helper functions for globbing
+
 (define (contains-glob-enumerator? arg)
   (if-match
    (regexp-search 
@@ -28,28 +30,73 @@
 	(error "no files match this glob expression" arg (cwd))
 	files)))
 
-(define (expand-command-argument arg)
-  (let ((expanded (expand-file-name arg)))
-    (cond 
-     ((contains-glob-expression? arg)
-      (glob-argument expanded))
-     (else (list expanded)))))
+;; expand command list:
+;; - substiute environment vars in strings with their values
+;; - globbing
 
-(define (expand-argument-list args)
-  (fold-right
-   (lambda (arg expanded)
-     (append (expand-command-argument arg) expanded))
-   '() args))
+(define (env-var-name str)
+  (cond
+   ((regexp-search 
+     (rx (: #\$ (? #\{) (submatch (+ (- ascii #\}))) (? #\}))) str)
+    => (lambda (matches)
+	 (match:substring matches 1)))
+   (else #f)))
 
+(define (lookup-env-var var)
+  (cond
+   ((assoc var (env->alist))
+    => cdr)
+   (else
+    (error "Undefined environment variable" var))))
+
+(define (substitute-env-vars str)
+  (cond
+   ((env-var-name str)
+    => lookup-env-var)
+   (else str)))
+
+(define (expand-string str)
+  (substitute-env-vars str))
+
+(define (expand-redirection redirection)
+  (make-redirection
+   (redirection-op redirection)
+   (expand-string (redirection-dest redirection))))
+
+(define (expand-command command)
+  (let ((expanded (map expand-string (command-args command))))
+    (make-command
+     (expand-string (command-executable command))
+     (fold-right 
+      (lambda (arg args)
+	(if (contains-glob-expression? arg)
+	    (append (glob-argument arg) args)
+	    (cons arg args)))
+      '() expanded)
+   (map expand-redirection (command-redirections command)))))
+
+(define (expand-command-line command-line)
+  (make-command-line
+   (expand-command (command-line-first-cmd command-line))
+   (map (lambda (combinator.command)
+	  (cons (car combinator.command)
+		(expand-command (cdr combinator.command))))
+	(command-line-combinator/cmds command-line))
+   (command-line-job-ctrl command-line)))
+
+;; #####
+;; it's a dumb idea to keep command and args separate, merge
+;; this stuff
 (define (standard-command-plugin-evaluater command args)
-  (def-prog-mode)
-  (endwin)
-  (newline)
-  (let ((status (run (,command ,@(expand-argument-list args)))))
-    (newline)
-    (display "Press any key to return to scsh-nuit...")
-    (wait-for-key)
-    status))
+  (let* ((parsed
+	  (parse-command-line
+	   (lex-command-line
+	    (string-append command " "
+			   (string-join args)))))
+	 (expanded (expand-command-line parsed))
+	 (s-expr (compile-command-line expanded)))
+    (debug-message "Compiled command " s-expr)
+    (eval-s-expr s-expr)))
 
 (define standard-command-plugin
   (make-command-plugin #f