commander-s/scheme/std-command.scm

(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))))