(define (standard-command-plugin-completer command args)
#f)
;; 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
(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/s-expr v)
(if (string? v)
(substitute-env-vars v)
v))
(define (expand-redirection redirection)
(make-redirection
(redirection-op redirection)
(expand-string/s-expr (redirection-dest redirection))))
(define (expand-command command)
(let ((expanded (map expand-string/s-expr (command-args command))))
(make-command
(expand-string/s-expr (command-executable command))
(fold-right
(lambda (arg args)
(if (and (string? arg) (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)
(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
standard-command-plugin-completer
standard-command-plugin-evaluater))
;; some common commands
(define no-completer #f)
(define just-run-in-foreground
(lambda (command args)
(run/fg* `(exec-epf (,command ,@args)))))
(define just-run-in-background
(lambda (command args)
(run/bg* `(exec-epf (,command ,@args)))))
;; Parse options for ls command using args-fold (SRFI 37)
;; We don't care for options that format the output.
(define defaults-ls-options
'((long . #t)
(dot-files? . #t)
(sort-by-mtime . #f)
(reverse-sort . #f)))
(define (parse-ls-arguments args)
(let* ((on/off-option-processor
(lambda (name)
(lambda (option arg-name arg ops)
(cons (cons name #t) ops))))
(long-option
(option '(#\l) #f #f
(on/off-option-processor 'long)))
(dotfiles-option
(option '(#\a) #f #f
(on/off-option-processor 'dot-files?)))
(sort-mtime-option
(option '(#\t) #f #f
(on/off-option-processor 'sort-by-mtime)))
(reverse-sort-option
(option '(#\r) #f #f
(on/off-option-processor 'reverse-sort))))
(let ((given-args
(args-fold
args
(list long-option dotfiles-option
sort-mtime-option reverse-sort-option)
(lambda (option name args operands)
(error "Unknown ls option" name))
cons '())))
(receive (options rest) (partition pair? given-args)
(values
(map (lambda (p)
(or (assoc (car p) options) p))
defaults-ls-options)
rest)))))
(register-plugin!
(make-command-plugin
"ls"
no-completer
(lambda (command args)
(debug-message "running ls plugin" command args)
(receive (options paths) (parse-ls-arguments args)
(let* ((set? (lambda (opt) (cdr (assoc opt options))))
(sort
(if (set? 'sort-by-mtime)
(lambda (lst)
(list-sort
(lambda (f g)
(< (file-info:mtime (fs-object-info f))
(file-info:mtime (fs-object-info g))))
lst))
(lambda (lst)
(list-sort
(lambda (f g)
(string<? (fs-object-name f) (fs-object-name g)))
lst))))
(reverse
(if (set? 'reverse-sort)
reverse
(lambda (l) l)))
(paths (if (null? paths)
(list (cwd))
paths)))
(reverse
(sort
(apply
append
(map (lambda (path)
(if (file-directory? path)
(directory-files path (set? 'dot-files?))
(list (file-name->fs-object path))))
paths)))))))))
(register-plugin!
(make-command-plugin "ps"
no-completer
(lambda (command args)
(pps))))
(register-plugin!
(make-command-plugin "pwd"
no-completer
(lambda (command args)
(cwd))))
(register-plugin!
(make-command-plugin
"cd"
(lambda (command to-complete)
(debug-message "cd-completer")
(complete-with-filesystem-objects
(lambda (file)
(call-with-current-continuation
(lambda (esc)
(with-handler
(lambda (c more)
(if (error? c)
(esc #f)
(more)))
(lambda ()
(and (file-directory? file)
(file-name-as-directory file)))))))
(or (to-complete-prefix to-complete) (cwd))))
(lambda (command args)
(chdir (resolve-file-name (if (null? args)
"~"
(car args))))
(cwd))))
(register-plugin!
(make-command-plugin "setenv"
no-completer
(lambda (command args)
(case (length args)
((0) (printenv))
((1) (getenv (car args)))
((2)
(setenv (car args) (cadr args))
0)
(else
(error "too many arguments to setenv" args))))))
(register-plugin!
(make-command-plugin "printenv"
no-completer
(lambda (command args)
(case (length args)
((0) (printenv))
((1) (getenv (car args)))
(else
(error "too many arguments to printenv"
args))))))
(define (printenv)
(env->alist))
(register-plugin!
(make-command-plugin "exit"
no-completer
(lambda (command args)
(clear)
(exit (if (null? args)
0
(string->number (car args)))))))
(register-plugin!
(make-command-plugin "jobs"
(lambda (command prefix args arg-pos)
'("running" "ready" "stopped" "output" "waiting-for-input"))
(lambda (command args)
(let ((selectors
`(("running" . ,running-jobs)
("ready" . ,ready-jobs)
("stopped" . ,stopped-jobs)
("output" . ,jobs-with-new-output)
("input" . ,jobs-waiting-for-input))))
(append-map
(lambda (arg)
(cond
((assoc arg selectors)
=> (lambda (p)
((cdr p))))))
(if (null? args)
(map car selectors)
(delete-duplicates args)))))))
(register-plugin!
(make-command-plugin
"latex"
(make-completer-for-file-with-extension '(".tex"))
just-run-in-foreground))
(register-plugin!
(make-command-plugin
"xdvi"
(make-completer-for-file-with-extension '(".dvi"))
just-run-in-background))
(register-plugin!
(make-command-plugin
"ftp"
(let* ((hosts '("ftp.gnu.org" "ftp.x.org"))
(cs (make-completion-set hosts)))
(lambda (command to-complete)
(debug-message "ftp completer " command "," to-complete)
(completions-for cs (or (to-complete-prefix to-complete) ""))))
just-run-in-foreground))
(define (make-debug-plugin val buffer)
(lambda (message)
(case message
((paint)
(lambda (self win buffer have-focus?)
(let ((cols (+ 0 (result-buffer-num-cols buffer)))
(lines (+ 0 (result-buffer-num-lines buffer))))
(wmove win 0 0)
(waddstr win "A")
(wmove win 0 cols)
(waddstr win "B")
(wmove win lines cols)
(waddstr win "C")
(wmove win lines 0)
(waddstr win "D")
(wrefresh win))))
(else
(lambda (self . more)
self)))))
(register-plugin!
(make-view-plugin make-debug-plugin (lambda (v) (eq? v 'debug))))