commander-s/scheme/cmdline.scm

;; ,open extended-ports define-record-types srfi-1 srfi-6 srfi-8 srfi-13 srfi-14 silly signals handle

;; command line language:
;;
;; <cmdline> ::= (<cmd> (<sep> <cmd>)* <jobctrl>?
;; <cmd>     ::= <prog> <arg>* <redir>*
;; <redir>   ::= <redirop> <fname>
;; <redirop> ::= ">" | ">>" | "<<" | "<"
;; <fname>   ::= <string> | <unquote>
;; <prog>    ::= <string> | <unquote>
;; <string>  ::= "..." | char+  with char = ASCII\{"&","|","<",">",","}
;; <jobctrl> ::= "&" | "&*"
;; <sep>     ::= "|" | "&&" | "||" | ";"
;; <unquote> ::= "," <s-expr> | ",@" <s-expr>

;; lexer stuff

(define-record-type token :token
  (make-token token type pos)
  token?
  (token token-token)
  (type token-type)
  (pos token-pos))

(define-record-discloser :token
  (lambda (r)
    `(token (,(token-type r) ,(token-pos r) ,(token-token r)))))

(define (make-string-token data pos)
  (make-token data 'string pos))

(define (string-token? thing)
  (and (token? thing) (eq? (token-type thing) 'string)))

(define (make-s-expr-token data pos)
  (make-token data 's-expr pos))

(define (s-expr-token? thing)
  (and (token? thing) (eq? (token-type thing) 's-expr)))

(define (make-operator-token data pos)
  (make-token data 'operator pos))

(define (operator-token? thing)
  (and (token? thing) (eq? (token-type thing) 'operator)))

(define operator-chars (char-set #\& #\| #\< #\> #\, #\;))

(define composed-operator-derivations 
  (char-set #\& #\* #\| #\> #\<))

(define (valid-operator? str)
  (member str '("&" "&&" "&*" "|" "||" "<" "<<" ">" ">>" "," ",@" ";")))

(define token-terminating-chars
  (char-set-union operator-chars char-set:whitespace))

(define (lex-token port)
  (let ((start-pos (current-column port)))
    (let lp ((c (peek-char port)) (chars '()))
      (cond
       ((or (eof-object? c)
	    (char-set-contains? token-terminating-chars c))
	(make-string-token 
	 (reverse-list->string chars (length chars))
	 start-pos))
       (else
	(read-char port)
	(lp (peek-char port) (cons c chars)))))))

(define (lex-operator port)
  (let ((start-pos (current-column port)) ; makes no sense, do it anyways
	(c-1 (read-char port))
	(c-2 (peek-char port)))
    (if (eof-object? c-2)
	(make-operator-token (string->symbol (string c-1)) start-pos)
	(let ((c (if (char-set-contains? composed-operator-derivations c-2)
		     (begin
		       (read-char port)
		   (string-append (string c-1) (string c-2)))
		     (string c-1))))
	  (cond 
	   ((valid-operator? c)
	    (make-operator-token (string->symbol c) start-pos))
	   (else
	    (error "Invalid operator in command line" c start-pos)))))))

(define (lex-port port)
  (let lp ((c (peek-char port)) (tokens '()))
    (cond
     ((eof-object? c)
      (reverse tokens))
     ((or (char=? c #\") (char=? c #\,))
      (let ((token (make-s-expr-token 
		    (read port) (current-column port))))
	(lp (peek-char port) (cons token tokens))))
     ((char-set-contains? operator-chars c)
      (let ((token (lex-operator port)))
	(lp (peek-char port) (cons token tokens))))
     ((char-set-contains? char-set:whitespace c)
      (read-char port)
      (lp (peek-char port) tokens))
     (else
      (let ((token (lex-token port)))
	(lp (peek-char port) (cons token tokens)))))))

(define (lex-command-line cmd-line)
  (lex-port 
   (make-tracking-input-port (make-string-input-port cmd-line))))

;; abstract syntax

(define-record-type command-line :command-line
  (make-command-line first-cmd combinator/cmds job-ctrl)
  command-line?
  (first-cmd command-line-first-cmd)
  (combinator/cmds command-line-combinator/cmds)
  (job-ctrl command-line-job-ctrl))

(define-record-discloser :command-line
  (lambda (r)
    `(command-line ,(command-line-first-cmd r)
		   ,(command-line-combinator/cmds r)
		   ,(command-line-job-ctrl r))))

(define-record-type command :command
  (make-command executable args redirections)
  command?
  (executable command-executable)
  (args command-args)
  (redirections command-redirections))

(define-record-discloser :command
  (lambda (r)
    `(command ,(command-executable r)
	      ,(command-args r) ,(command-redirections r))))

(define-record-type redirection :redirection
  (make-redirection op dest)
  redirection?
  (op redirection-op)
  (dest redirection-dest))

(define-record-discloser :redirection
  (lambda (r)
    `(redir ,(redirection-op r) ,(redirection-dest r))))

;; a simple recursive descent parser
(define (parse-error reason . more)
  (error (string-append "error parsing command line; " reason) 
	 more))

(define (parse-error-unexpected-end where)
  (parse-error "unexpected end of line" where))

(define (string-or-s-expr? token)
  (or (string-token? token) (s-expr-token? token)))

(define (parse-string/s-expr tokens)
  (if (null? tokens)
      (parse-error-unexpected-end 'parse-string/s-expr)
      (let ((t (car tokens)))
	(if (or (string-token? t) (s-expr-token? t))
	    (values (token-token t) (cdr tokens))
	    (parse-error 
	     "not a string or s-expr" 'parse-string/s-expr
	     t tokens)))))

(define (parse-many-satisfying predicate tokens)
  (let lp ((tokens tokens) (found '()))
    (if (or (null? tokens) (not (predicate (car tokens))))
	(values (reverse found) tokens)
	(lp (cdr tokens) (cons (car tokens) found)))))

(define (parse-redirection tokens)
  (if (< (length tokens) 2)
      (values #f tokens)
      (let ((op (car tokens))
	    (obj (cadr tokens)))
	(cond
	 ((and (operator-token? op)
	       (member (token-token op) '(> < >>))
	       (string-or-s-expr? obj))
	  (values 
	   (make-redirection (token-token op) (token-token obj))
	   (cddr tokens)))
	 ((and (operator-token? op)
	       (eq? (token-token op) '<<)
	       (s-expr-token? obj))
	  (values 
	   (make-redirection (token-token op) (token-token obj))
	   (cddr tokens)))
	 (else
	  (values #f tokens))))))

(define (parse-redirections tokens)
  (let lp ((tokens tokens) (redirs '()))
    (receive (redir tokens)
	(parse-redirection tokens)
      (if redir
	  (lp tokens (cons redir redirs))
	    (values (reverse redirs) tokens)))))

(define (parse-command tokens)
  (receive (executable tokens)
      (parse-string/s-expr tokens)
    (receive (args tokens)
	(parse-many-satisfying string-or-s-expr? tokens)
      (receive (redirs tokens)
	  (parse-redirections tokens)
	(values (make-command executable 
			      (map token-token args) redirs) 
		tokens)))))

(define combinator-tokens
  (map string->symbol '(";" "|" "&&" "||")))

(define (combinator-token? token)
  (and (operator-token? token)
       (member (token-token token) combinator-tokens)))

(define (parse-combinator/command tokens)
  (if (< (length tokens) 2)
      (values #f tokens)
      (let ((comb (car tokens))
	    (cmd (cdr tokens)))
	(cond
	 ((combinator-token? comb)
	  (receive (command tokens)
	      (parse-command cmd)
	    (values (cons (token-token comb) command)
		    tokens)))
	 (else
	  (values #f tokens))))))

(define (parse-combinators/commands-list tokens)
  (let lp ((tokens tokens) (combs/cmds '()))
    (receive (comb/cmd tokens)
	(parse-combinator/command tokens)
      (if comb/cmd
	  (lp tokens (cons comb/cmd combs/cmds))
	  (values (reverse combs/cmds) tokens)))))

(define (parse-job-control tokens)
  (if (null? tokens)
      (values #f tokens)
      (let ((t (car tokens)))
	(if  (and (operator-token? t)
		  (member (token-token t) '(&& &)))
	     (values (token-token t) (cdr tokens))
	     (values #f tokens)))))
	
(define (parse-command-line tokens)
  (receive (command tokens)
      (parse-command tokens)
    (receive (combinator/command-list tokens)
	(parse-combinators/commands-list tokens)
      (receive (job-control tokens)
	  (parse-job-control tokens)
	(if (null? tokens)
	    (make-command-line command combinator/command-list
			       job-control)
	    (error "error parsing command line" tokens))))))

;; unparser

(define append* 
  (lambda args
    (apply append
	   (map (lambda (arg)
		  (if (pair? arg)
		      arg
		      (list arg)))
		(filter (lambda (v) (not (null? v)))
			args)))))

(define string-join*
  (lambda args
    (string-join (apply append* args))))

(define (unparse-arbitrary v)
  (let ((p (open-output-string)))
    (display v p)
    (get-output-string p)))

(define (unparse-string/s-expr v)
  (cond
   ((string? v) v)
   ((and (pair? v) (eq? (car v) 'unquote))
    (string-append 
     "," (unparse-arbitrary (cadr v))))
   ((and (pair? v) (eq? (car v) 'unquote-splicing))
    (string-append
     ",@" (unparse-arbitrary (cadr v))))
   (else
    (unparse-arbitrary v))))

(define (unparse-redirection rd)
  (string-join*
   (symbol->string (redirection-op rd))
   (unparse-string/s-expr (redirection-dest rd))))

(define (unparse-command cmd)
  (string-join*
   (unparse-string/s-expr (command-executable cmd))
   (map unparse-string/s-expr (command-args cmd))
   (map unparse-redirection 
	(command-redirections cmd))))

(define (unparse-command-line cmdln)
  (string-join*
   (unparse-command (command-line-first-cmd cmdln))
   (map (lambda (comb.cmd)
	  (string-append
	   (symbol->string (car comb.cmd))
	   " "
	   (unparse-command (cdr comb.cmd))))
	(command-line-combinator/cmds cmdln))
   (cond ((command-line-job-ctrl cmdln)
	  => symbol->string)
	 (else '()))))