diff --git a/scheme/cmdline.scm b/scheme/cmdline.scm new file mode 100644 index 0000000..b4d4159 --- /dev/null +++ b/scheme/cmdline.scm @@ -0,0 +1,321 @@ +;; ,open extended-ports define-record-types srfi-1 srfi-6 srfi-8 srfi-13 srfi-14 silly signals handle + +;; command line language: +;; +;; ::= ( ( )* ? +;; ::= * * +;; ::= +;; ::= ">" | ">>" | "<<" | "<" +;; ::= | +;; ::= | +;; ::= "..." | char+ with char = ASCII\{"&","|","<",">",","} +;; ::= "&" | "&*" +;; ::= "|" | "&&" | "||" | ";" +;; ::= "," | ",@" + +;; 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 '())))) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 79b33a1..6918702 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -558,6 +558,67 @@ console) (files job)) +;;; command line parser + +(define-interface command-line-lexer-tokens-interface + (export + token? token-token token-type token-pos + string-token? + s-expr-token? + operator-token?)) + +(define-interface command-line-lexer-interface + (export lex-command-line)) + +(define-interface command-line-absyn-interface + (export + command-line? + command-line-first-cmd + command-line-combinator/cmds + command-line-job-ctrl + + command? + command-executable + command-args + command-redirections + + redirection? + redirection-op + redirection-dest)) + +(define-interface command-line-absyn-constructors-interface + (export + make-command-line + make-command + make-redirection)) + +(define-interface command-line-parser-interface + (export parse-command-line + unparse-command-line)) + +(define-structures + ((command-line-lexer (compound-interface + command-line-lexer-tokens-interface + command-line-lexer-interface)) + (command-line-parser (compound-interface + command-line-absyn-interface + command-line-parser-interface)) + (command-line-absyn (compound-interface + command-line-absyn-interface + command-line-absyn-constructors-interface))) + (open scheme + extended-ports + define-record-types + (subset srfi-1 (filter)) + srfi-6 + srfi-8 + (subset srfi-13 (string-join)) + srfi-14 + silly + signals + handle) + (files cmdline)) + ;;; nuit (define-interface nuit-interface