commander-s/scheme/cmdline.scm

;; ,open conditions 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
  (really-make-token token type start-pos cursor-pos)
  token?
  (token token-token)
  (type token-type)
  (start-pos token-start-pos)
  (cursor-pos token-cursor-pos))

;; all indices and positions are zero-based

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

(define (make-token token type start-pos cursor-index port)
  (really-make-token 
   token type start-pos
   (and cursor-index
	(<= start-pos cursor-index (current-column port))
	(- cursor-index start-pos))))

(define (make-string-token data start-pos cursor-index port)
  (make-token data 'string start-pos cursor-index port))

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

(define (make-s-expr-token data start-pos cursor-index port)
  (make-token data 's-expr start-pos cursor-index port))

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

(define (make-operator-token data start-pos cursor-index port)
  (make-token data 'operator start-pos cursor-index port))

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

(define (cursor-on-token? token)
  (or (to-complete? token)
      (integer? (token-cursor-pos token))))

(define-record-type to-complete :to-complete
  (make-to-complete prefix pos)
  to-complete?
  (prefix to-complete-prefix)
  (pos to-complete-pos))

(define-record-discloser :to-complete
  (lambda (r)
    `(to-complete ,(to-complete-prefix r) ,(to-complete-pos r))))

(define to-complete-without-prefix?
  to-complete-prefix)

(define (make-empty-to-complete pos)
  (make-to-complete #f pos))

(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 cursor-index 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 cursor-index port))
       (else
	(read-char port)
	(lp (peek-char port) (cons c chars)))))))

(define (lex-operator cursor-index port)
  (let ((start-pos (current-column port))
	(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 cursor-index port)
	(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 cursor-index port))
	   (else
	    (error "Invalid operator in command line" c start-pos)))))))

(define (lex-port cursor-index port)
  (let lp ((c (peek-char port)) (tokens '()))
    (cond
     ((eof-object? c)
      (reverse tokens))
     ((or (char=? c #\") (char=? c #\,))
      (let* ((start-pos (current-column port))
	     (s-expr (read port))
	     (token 
	      (make-s-expr-token 
	       s-expr start-pos cursor-index port)))
	(lp (peek-char port) (cons token tokens))))
     ((char-set-contains? operator-chars c)
      (let ((token (lex-operator cursor-index port)))
	(lp (peek-char port) (cons token tokens))))
     ((char-set-contains? char-set:whitespace c)
      (let ((start-pos (current-column port)))
	(read-char port)
	(let read-whitspaces ((c (peek-char port))
			      (cursor? #f))
	  (cond
	   ((eof-object? c)
	    (lp c (if (or cursor?
			  (and cursor-index
			       (= (current-column port) cursor-index)))
		      (cons (make-empty-to-complete cursor-index)
			    tokens)
		      tokens)))
	   ((char-set-contains? char-set:whitespace c)
	    (read-char port)
	    (read-whitspaces (peek-char port) 
			     (or cursor?
				 (and cursor-index
				      (= (current-column port) cursor-index)))))
	   (else (lp c tokens))))))
     (else
      (let ((token (lex-token cursor-index port)))
	(lp (peek-char port) (cons token tokens)))))))

(define (lex-command-line cmd-line . args)
  (let-optionals args
      ((cursor-index #f))
    (with-handler 
     (lambda (c more)
       (if (read-error? c)
	   (signal-syntax-error (condition-stuff c))
	   (more)))
     (lambda ()
       (lex-port
	cursor-index
	(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))))

;; condition raised during parsing

(define-condition-type 'parser-error '(error))
(define parser-error? (condition-predicate 'parser-error))

(define-condition-type 'parser-syntax-error '(parser-error))
(define parser-syntax-error? 
  (condition-predicate 'parser-syntax-error))

(define-condition-type 'parser-unexpected-eof '(parser-error))
(define parser-unexpected-eof? 
  (condition-predicate 'parser-unexpected-eof))

(define (signal-syntax-error info)
  (signal 'parser-syntax-error info))

(define (signal-unexpected-eof info)
  (signal 'parser-unexpected-eof info))

;; a simple recursive descent parser

(define (extract-token t)
  (cond
   ((to-complete? t) 
    t)
   ((cursor-on-token? t)
    (make-to-complete (token-token t) (token-cursor-pos t)))
   (else 
    (token-token t))))

(define (string-or-s-expr? t)
  (or (string-token? t)
      (s-expr-token? t)
      (to-complete? t)))

(define (parse-string/s-expr tokens)
  (if (null? tokens)
      (signal-unexpected-eof 'parse-string/s-expr)
      (let ((t (car tokens)))
	(if (or (string-token? t) (s-expr-token? t))
	    (values (extract-token t) (cdr tokens))
	    (signal-syntax-error `(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) (extract-token obj))
	   (cddr tokens)))
	 ((and (operator-token? op)
	       (eq? (token-token op) '<<)
	       (s-expr-token? obj))
	  (values 
	   (make-redirection (token-token op) (extract-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 extract-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 (extract-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)
	    (signal-syntax-error `(parse-command-line ,tokens)))))))

;; for use with tab completion
(define (parse-command-line-carefully tokens)
  (call-with-current-continuation
   (lambda (esc)
     (with-handler
      (lambda (condition . more)
	(if (parser-error? condition)
	    (esc #f)
	    (more)))
      (lambda ()
	(parse-command-line tokens))))))

(define (lex/parse-partial-command-line cmdln cursor-index)
  (let ((tokens (lex-command-line cmdln cursor-index)))
    (let lp ((tokens tokens))
      (cond 
       ((null? tokens)
	(make-command-line 
	 (make-command (make-to-complete #f 0) '() '())
	 '() #f))
       ((parse-command-line-carefully tokens)
	=> (lambda (v) v))
       (else
	(lp (drop-right tokens 1)))))))

;; unparser

(define (unparse-string/s-expr completion pos v start-of-line?)
  (if (not start-of-line?)
      (display " "))
  (cond
   ((and completion (to-complete? v))
    (completion v)
    (cell-set! pos (current-column (current-output-port))))
   ((string? v)
    (display v))
   ((and (pair? v) (eq? (car v) 'unquote))
    (display ",")
    (display (cadr v)))
   ((and (pair? v) (eq? (car v) 'unquote-splicing))
    (display ",@")
    (display (cadr v)))
   (else
    (error "Don't know how to unparse this." v))))

(define (unparse-redirection completion pos rd)
  (display " ")
  (display (symbol->string (redirection-op rd)))
  (unparse-string/s-expr completion pos
			 (redirection-dest rd) #f))

(define (unparse-command completion pos cmd start-of-line?)
  (unparse-string/s-expr completion pos (command-executable cmd) start-of-line?)
  (for-each (lambda (arg)
	      (unparse-string/s-expr completion pos arg #f))
	    (command-args cmd))
  (for-each (lambda (arg)
	      (display " ")
	      (unparse-redirection completion pos arg))
	    (command-redirections cmd)))

(define (unparse-command-line cmdln . arg)
  (let-optionals arg
      ((completion #f))
    (let* ((pos (make-cell #f))
	   (string-port (make-string-output-port))
	   (track-port (make-tracking-output-port string-port)))
      (with-current-output-port track-port
	(unparse-command completion pos
			 (command-line-first-cmd cmdln) #t)
	(for-each 
	 (lambda (comb.cmd)
           (display " ")
           (display (symbol->string (car comb.cmd)))
	   (unparse-command completion pos (cdr comb.cmd) #f))
	 (command-line-combinator/cmds cmdln))
	(cond
	 ((command-line-job-ctrl cmdln)
	  => (lambda (sym)
	       (display " ")
	       (display (symbol->string sym)))))
	;; we're done
	(close-output-port track-port)
	(values (string-output-port-output string-port)
		(cell-ref pos))))))

;;; cmdline expansion

;; helper functions for globbing

(define (contains-glob-enumerator? arg)
  (if-match
   (regexp-search 
    (rx (: (submatch (* any)) ("{[") (* any) (submatch (* any)) ("]}")))
    arg)
   (whole-arg submatch-before submatch-after)
   (not (or (string-suffix? "\\" submatch-before)
	    (string-suffix? "\\" submatch-after)))
   #f))

(define (contains-glob-wildcard? arg)
  (if-match
   (regexp-search (rx (: (submatch (* any)) ("*?"))) arg)
   (whole-arg submatch-before)
   (not (string-suffix? "\\" submatch-before))
   #f))
   
(define (contains-glob-expression? arg)
  (or (contains-glob-wildcard? arg)
      (contains-glob-enumerator? arg)))

(define (glob-argument arg)
  (let ((files (glob arg)))
    (if (null? files)
	(error "no files match this glob expression" arg (cwd))
	files)))

;; expand command list:
;; - substiute environment vars in strings with their values
;; - globbing
;; - tilde expansion


(define (substitute-env-vars str)
  (regexp-substitute/global
   #f
   (rx (: #\$ (? #\{) (submatch (+ alphanum)) (? #\})))
   str
   'pre
   (lambda (m)
     (or (lookup-env-var (match:substring m 1)) (match:substring m 1)))
   'post))
  

(define (expand-filename-string s)
  (debug-message "expand-filename-string " s)
  (resolve-file-name (substitute-env-vars s)))

(define (expand-string/s-expr v)
  (if (string? v)
      (expand-filename-string v)
      v))

(define (expand/glob-arguments args)
  (fold-right 
      (lambda (arg args)
	(let ((expanded (expand-string/s-expr arg)))
          (if (and (string? expanded) (contains-glob-expression? expanded))
              (append (glob-argument expanded) args)
              (cons expanded args))))
      '() args))

(define (expand-redirection redirection)
  (make-redirection
   (redirection-op redirection)
   (expand-string/s-expr (redirection-dest redirection))))

(define (expand-command command)
  (make-command
   (expand-string/s-expr (command-executable command))
   (expand/glob-arguments (command-args command))
   (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)))