265 lines
7.9 KiB
Scheme
265 lines
7.9 KiB
Scheme
(define (standard-command-plugin-completer command args)
|
|
#f)
|
|
|
|
|
|
;; #####
|
|
;; 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/command 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 ,@(expand/glob-arguments args))))))
|
|
|
|
(define just-run-in-background
|
|
(lambda (command args)
|
|
(run/bg* `(exec-epf (,command ,@(expand/glob-arguments 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 . #f)
|
|
(dot-files? . #f)
|
|
(sort-by-mtime . #f)
|
|
(dont-sort . #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)))
|
|
(dont-sort-option
|
|
(option '(#f) #f #f
|
|
(on/off-option-processor 'dont-sort)))
|
|
(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 dont-sort-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) ;; 'long is ignored
|
|
(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))
|
|
|
|
(if (set? 'dont-sort)
|
|
(lambda (lst) 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 (file-name-as-directory (cwd)))
|
|
paths))
|
|
(dot-files? (set? 'dot-files?)))
|
|
(reverse
|
|
(sort
|
|
(apply
|
|
append
|
|
(map (lambda (path)
|
|
(if (file-directory? path)
|
|
(if dot-files?
|
|
(cons (file-name->fs-object ".")
|
|
(cons (file-name->fs-object "..")
|
|
(directory-files path dot-files?)))
|
|
(directory-files path dot-files?))
|
|
(list (file-name->fs-object path))))
|
|
(expand/glob-arguments 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"
|
|
no-completer
|
|
(lambda (command args)
|
|
(let* ((exp-args (expand/glob-arguments args))
|
|
(arg (if (null? exp-args)
|
|
(getenv "HOME")
|
|
(if (null? (cdr exp-args))
|
|
(car exp-args)
|
|
(error "too many arguments to cd" exp-args)))))
|
|
(chdir arg)
|
|
(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"
|
|
(lambda (command to-complete)
|
|
(completions-for
|
|
(make-completion-set
|
|
(map car (env->alist)))
|
|
(or (to-complete-prefix to-complete) "")))
|
|
(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)))))))
|
|
|
|
(define jobs-completion-set
|
|
(make-completion-set
|
|
'("running" "ready" "stopped"
|
|
"output" "waiting-for-input")))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "jobs"
|
|
(lambda (command to-complete)
|
|
(completions-for
|
|
jobs-completion-set
|
|
(or (to-complete-prefix to-complete) "")))
|
|
(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))))
|