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 commands

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

(define (find-completions-for-command cmd to-complete)
  (debug-message "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)))))))

;; the main part

(define (find-plugin-completer cmd)
  (let ((cmd-name (command-executable cmd)))
    (cond
     ((find (lambda (p)
	      (string=? (command-plugin-command p) cmd-name))
	    (command-plugin-list))
      => (lambda (plugin)
	   (or (command-plugin-completer plugin)
	       find-completions-for-arg)))
     (else find-completions-for-arg))))

(define (find-completer type . args)
  (let-optionals args
      ((cmd #f))
    (case type
      ((command) find-completions-for-command)
      ((redir-dest) find-completions-for-redir)
      ((arg) (if cmd
		 (find-plugin-completer cmd)
		 find-completions-for-arg))
      (else
       (error "Unknown completion type" type)))))

(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) cmd to-complete)))
	     (debug-message "Possible completions " completions)
	     (case (length completions)
               ((0) #f)
               ((1)
	       (call-with-values
		   (lambda ()
		     (unparse-command-line 
		      parsed (lambda (to-complete)
			       (display (car completions)))))
		 (lambda (completed-line cursor-index)
		   (list completed-line '() cursor-index to-complete parsed))))
              (else
               (let ((common-prefix (strings-common-prefix completions))
                     (prefix (to-complete-prefix to-complete)))
                 (debug-message "common-prefix is" common-prefix)
                 (if (> (string-length common-prefix)
                        (if prefix
                            (string-length prefix)
                            0))
                     (call-with-values
                         (lambda ()
                           (unparse-command-line
                            parsed (lambda (to-complete)
                                     (display common-prefix))))
                       (lambda (completed-line cursor-index)
                         (list completed-line '()
                               cursor-index to-complete parsed)))
                     (list #f completions cursor-index to-complete parsed))))))))))


(define (strings-common-prefix strs)
  (let lp ((strs (cdr strs))
           (len (string-length (car strs)))
           (common (car strs)))
    (if (null? strs)
        common
        (let ((new (string-prefix-length (car strs)
                                         common)))
          (if (< new len)
              (lp (cdr strs)
                  new
                  (string-take common new))
              (lp (cdr strs)
                  len
                  common))))))