commander-s/scheme/completer.scm

;;; #### also used in nuit-engine.scm move to some utils module
(define-syntax with-lock
  (syntax-rules ()
    ((_ lock exp ...)
     (begin
       (obtain-lock lock)
       (let ((val (begin exp ...)))
	 (release-lock lock)
	 val)))))

;; completion set for executables in PATH

(define executable-completions-lock (make-lock))
(define executable-completions #f)

(define (get-path-list)
  (cond
   ((getenv "PATH")
    => (lambda (str)
	 (string-tokenize 
	  str (char-set-difference char-set:full (char-set #\:)))))
   (else
    '("/usr/bin" "/bin" "/usr/sbin" "/sbin"))))

(define (init-executables-completion-set!)
  (spawn
   (lambda ()
     (with-lock executable-completions-lock
       (set! executable-completions 
	     (make-completion-set-for-executables (get-path-list)))))))

;; find the part of the command line the user wants to complete

(define (make-scan-for-completions cmd-selector selector symbol)
  (lambda (cmd)
    (let lp ((things (cmd-selector cmd)))
      (cond
       ((null? things)
	#f)
       ((to-complete? (selector (car things)))
	(list symbol cmd (selector (car things))))
       (else
	(lp (cdr things)))))))

(define scan-redirections-for-completions
  (make-scan-for-completions
   command-redirections redirection-dest 'redir-dest))

(define scan-args-for-completions
  (make-scan-for-completions
   command-args (lambda (v) v) 'arg))

(define (scan-command-for-completions cmd)
  (cond
   ((to-complete? (command-executable cmd))
    (list 'command cmd (command-executable cmd)))
   ((scan-redirections-for-completions cmd)
    => (lambda (v) v))
   ((scan-args-for-completions cmd)
    => (lambda (v) v))
   (else #f)))

(define (scan-command-line-for-completions cmdln)
  (cond
   ((scan-command-for-completions 
     (command-line-first-cmd cmdln))
    => (lambda (v) v))
   (else
    (let lp ((lst (command-line-combinator/cmds cmdln)))
      (cond
       ((null? lst) #f)
       ((scan-command-for-completions (cdar lst))
	=> (lambda (v) v))
       (else (lp (cdr lst))))))))

;; completion functions for arguments and redirection 

(define (find-completions-for-arg cmd to-complete)
  (let ((prefix (to-complete-prefix to-complete)))
    (if prefix
	(complete-files/path (expand-file-name prefix (cwd)))
	(complete-files/path prefix))))

;; #### no special treatment yet
(define find-completions-for-redir find-completions-for-arg)

;; completion functions for commands

(define (find-completions-for-command cmd to-complete)
  (let ((prefix (or (to-complete-prefix to-complete) "")))
    (cond
     ((command-contains-path? prefix)
      ;; #### install error handler
      (complete-executables/path 
       (expand-file-name prefix (cwd))))
     (else
      (append
       (completions-for (command-completions) prefix)
       (with-lock executable-completions-lock
	 (completions-for-executables 
	  executable-completions prefix)))))))

;; some helpers for the implementation of completion functions

(define (command-contains-path? command)
  (or (string-contains command "/")
      (string-contains command "~")
      (string-contains command "..")))

(define (files-in-dir file-filter dir)
  (with-cwd dir
    (filter-map 
     (lambda (file)
       (and (file-filter file)
	    (absolute-file-name file dir)))
     (directory-files))))

(define (complete-path path)
  (let ((dir (file-name-directory path)))
    (map (lambda (p) 
	   (if (string-prefix? "/" p)
	       p
	       (string-append dir p)))
	 (glob (string-append path "*")))))

(define (file-exists-and-is-directory? fname)
  (call-with-current-continuation
   (lambda (esc)
     (with-handler 
      (lambda (c more)
	(if (error? c)
	    (esc #f)
	    (more)))
      (lambda ()
	(and (file-exists? fname) (file-directory? fname)))))))

(define (complete-with-filesystem-objects filter partial-name)
  (if (file-exists-and-is-directory? partial-name)
      (files-in-dir filter partial-name)
      (complete-path partial-name)))

(define (complete-executables/path partial-name)
  (complete-with-filesystem-objects
   (lambda (file) 
     (call-with-current-continuation
      (lambda (esc)
	(with-handler
	 (lambda (c more)
	   (if (error? c)
	       (esc #f)
	       (more)))
	 (lambda ()
	   (or (file-executable? file) (file-directory? file)))))))
   partial-name))

(define (complete-files/path partial-name)
  (complete-with-filesystem-objects
   (lambda (file) #t) partial-name))

;; insert the completion into the command line

(define (assemble-redirection replacer redir)
  (make-redirection
   (redirection-op redir)
   (replacer (redirection-dest redir))))

(define (assemble-command replacer cmd)
  (let ((assemble-redirection
	 (lambda (obj) (assemble-redirection replacer obj))))
    (make-command 
     (replacer (command-executable cmd))
     (map replacer (command-args cmd))
     (map assemble-redirection (command-redirections cmd)))))

(define (assemble-command-line replacer cmdln)
  (let ((assemble-command 
	 (lambda (cmd) (assemble-command replacer cmd))))
    (make-command-line
     (assemble-command (command-line-first-cmd cmdln))
     (map (lambda (p)
	    (cons (car p) (assemble-command (cdr p))))
	  (command-line-combinator/cmds cmdln))
     (command-line-job-ctrl cmdln))))

(define (assemble-with-completion cmdln to-complete completion)
  (assemble-command-line (lambda (obj)
			   (if (eq? obj to-complete)
			       completion
			       obj))
			 cmdln))

;; the main part

(define (find-completer type)  
  (case type
    ((arg) find-completions-for-arg)
    ((command) find-completions-for-command)
    ((redir-dest) find-completions-for-redir)
    (else
     (error "Unknown completion type" type))))

(define (calculate-cursor-index to-complete completion)
  (+ (to-complete-pos to-complete) (string-length completion)))
  
(define (complete cmdln cursor-index)
  (debug-message "complete " cmdln ", " cursor-index)
  (let* ((parsed
	  (lex/parse-partial-command-line cmdln cursor-index))
	 (completion-info
	  (scan-command-line-for-completions parsed)))
    (debug-message "complete " completion-info)
    (and completion-info
	 (destructure (((type cmd to-complete) completion-info))
	   (let ((completions ((find-completer type) cmd to-complete)))
	     (cond
	      ((= (length completions) 1)
	       (list (unparse-command-line
		      (assemble-with-completion parsed to-complete
						(car completions)))
		     (calculate-cursor-index to-complete 
					     (car completions))
		     to-complete parsed))
	      (else 
	       (list completions cursor-index to-complete parsed))))))))