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)
  (debug-message "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 ""))))

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

;; 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)
  (debug-message "complete-files/path " partial-name)
  (complete-with-filesystem-objects
   (lambda (file) #t) partial-name))

;; 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)))
	     (cond
	      ((= (length completions) 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 
	       (list completions cursor-index to-complete parsed))))))))