Make completions for commands work. Infrastructure for completions of

arbitrary args.

scheme/nuit-engine.scm

@@ -42,6 +42,8 @@
 (define result-window #f)
 (define result-frame-window #f)
 
+(define executable-completions #f)
+
 (define key-control-x 24)
 (define key-o 111)
 (define key-tab 9)
@@ -275,38 +277,70 @@
 (define (run)
 
   (init-windows!)
+  (init-executables-completion-set!)
+
   '(set-interrupt-handler interrupt/keyboard 
 			  (lambda a 
 			    (set! active-keyboard-interrupt a)))
       
   ;;Loop
   (paint)
-  (let loop ((ch (wait-for-input)) (c-x-pressed? #f))
+  (let loop ((ch (wait-for-input)) (c-x-pressed? #f)
+	     (completion-select-list #f))
+
     (cond
 
      ;; Ctrl-x -> wait for next input
      ((= ch key-control-x)
-      (loop (wait-for-input) #t))
+      (loop (wait-for-input) #t completion-select-list))
 
+     ;; user hit tab twice and pressed some other key to navigate the
+     ;; completion-select-list
+     ((and (focus-on-result-buffer?) completion-select-list)
+      (if (= ch 10)
+	  (begin
+	    (focus-command-buffer!)
+	    (complete-in-command-buffer 
+	     (last (buffer-text command-buffer))
+	     (select-list-selected-entry completion-select-list))
+	    (loop (wait-for-input) c-x-pressed? #f))
+	  (let ((select-list
+		 (select-list-handle-key-press 
+		  completion-select-list
+		  (make-key-pressed-message (active-command) (current-result)
+					    result-buffer ch #f))))
+	    (paint-completion-select-list 
+	     select-list (last (buffer-text command-buffer)))
+	    (loop (wait-for-input) c-x-pressed? select-list))))
+
+     ;; tab pressed twice, select completion using select-list
+     ((and (focus-on-command-buffer?)
+	   completion-select-list
+	   (= ch key-tab))
+      (focus-result-buffer!)
+      (loop (wait-for-input) #f completion-select-list))
+
+     ;; tab is pressed in the first place, offer completions
      ((and (focus-on-command-buffer?)
 	   (= ch key-tab))
-      (offer-completions (last (buffer-text command-buffer)))
-      (loop (wait-for-input) #f))
+      (let ((maybe-select-list
+	     (offer-completions (last (buffer-text command-buffer)))))
+	(loop (wait-for-input) #f maybe-select-list)))
 
      ;; F7 toggle scheme-mode / command-mode (FIXME: find a better key)
      ((= ch key-f7)
       (toggle-command/scheme-mode)
-      (loop (wait-for-input) #f))
+      (loop (wait-for-input) #f #f))
 
      ((= ch key-f8)
       (show-shell-screen)
       (paint)
-      (loop (wait-for-input) #f))
+      (loop (wait-for-input) #f #f))
 
      ;; C-x o --- toggle buffer focus
      ((and c-x-pressed? (= ch key-o))
       (toggle-buffer-focus)
-      (loop (wait-for-input) #f))
+      (loop (wait-for-input) #f #f))
 
      ;; C-x p --- insert selection
      ((and c-x-pressed? 
@@ -317,7 +351,7 @@
        (post-message 
 	(history-entry-plugin (entry-data (current-history-item)))
 	(make-selection-message (active-command) (current-result))))
-      (loop (wait-for-input) #f))
+      (loop (wait-for-input) #f #f))
 
      ((and c-x-pressed? (focus-on-result-buffer?))
       (let ((key-message
@@ -329,7 +363,7 @@
 	 (post-message
 	  (history-entry-plugin (entry-data (current-history-item)))
 	  key-message))
-	(loop (wait-for-input) #f)))
+	(loop (wait-for-input) #f #f)))
 
      ;; C-x r --- redo
      ((and c-x-pressed? (focus-on-command-buffer?)
@@ -341,7 +375,7 @@
      
      ((= ch key-f2)
       (paint)
-      (loop (wait-for-input) c-x-pressed?))
+      (loop (wait-for-input) c-x-pressed? #f))
 
      ;; forward in result history
      ((= ch key-npage)
@@ -350,7 +384,7 @@
 	(paint-active-command-window)
 	(paint-result-window (entry-data (current-history-item))))
       (refresh-result-window)
-      (loop (wait-for-input) c-x-pressed?))
+      (loop (wait-for-input) c-x-pressed? #f))
      
      ;; back in result history
      ((= ch key-ppage)
@@ -359,11 +393,11 @@
 	(paint-active-command-window)
 	(paint-result-window (entry-data (current-history-item))))
       (refresh-result-window)
-      (loop (wait-for-input) c-x-pressed?))
+      (loop (wait-for-input) c-x-pressed? #f))
 
      ((and (focus-on-command-buffer?) (= ch 10))
       (handle-return-key)
-      (loop (wait-for-input) c-x-pressed?))
+      (loop (wait-for-input) c-x-pressed? #f))
 
      (else 
       (cond
@@ -379,7 +413,7 @@
 	  (paint-result-window (entry-data (current-history-item)))
 	  (move-cursor command-buffer result-buffer)
 	  (refresh-result-window))
-	(loop (wait-for-input) #f))
+	(loop (wait-for-input) #f #f))
        (else
 	(input command-buffer ch)
 	(werase (app-window-curses-win command-window))
@@ -387,7 +421,7 @@
 			      command-buffer)
 	(move-cursor command-buffer result-buffer)
 	(refresh-command-window)
-	(loop (wait-for-input) c-x-pressed?)))))))
+	(loop (wait-for-input) c-x-pressed? #f)))))))
 
 (define (window-init-curses-win! window)
   (set-app-window-curses-win!
@@ -446,6 +480,19 @@
 	      (map app-window-curses-win all-windows))
     (clear)))
 
+(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!)
+  (set! executable-completions 
+	(make-completion-set-for-executables (get-path-list))))
+
 (define (paint-bar-1)
   (mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT")
   (wrefresh (app-window-curses-win bar-1)))
@@ -741,21 +788,136 @@
 	(loop (cdr lst)
 	      (string-append str " " (car lst))))))
 
-(define (completions->select-list completions)
+(define (completions->select-list completions num-lines)
   (debug-message "possible completions " completions)
   (make-select-list
    (map (lambda (s) (make-unmarked-element s #f s))
 	completions)
-   (result-buffer-num-lines result-buffer)))
+   num-lines))
+
+(define (command-contains-path? command)
+  (or (string-contains command "/")
+      (string-contains command "~")
+      (string-contains command "..")))
+
+(define (executables-in-dir dir)
+  (with-cwd dir
+    (filter-map 
+     (lambda (file)
+       (and (or (file-executable? file) (file-directory? 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 (complete-executable/path command)
+  (if (and (file-exists? command) (file-directory? command))
+      (executables-in-dir command)
+      (complete-path command)))
+
+(define (command-mode-complete command)
+  (cond
+   ((command-contains-path? command)
+    (let ((new
+	   (complete-executable/path (expand-file-name command (cwd)))))
+      (debug-message "command-mode-complete " command)
+      new))
+   (else
+    (append
+     (completions-for (command-completions) command)
+     (completions-for-executables executable-completions command)))))
+	
+(define (complete-in-command-buffer command completion)
+  (let ((rest (substring completion 
+			 (string-length command)
+			 (string-length completion))))
+    (debug-message "complete-in-command-buffer "
+		   "'" command "'; '" completion "'; "
+		   "'" rest "'")
+    (for-each (lambda (c)
+		(input command-buffer (char->ascii c)))
+	      (string->list rest))
+    (wclrtoeol (app-window-curses-win command-window))
+    (print-command-buffer (app-window-curses-win command-window)
+			  command-buffer)
+    (move-cursor command-buffer result-buffer)
+    (refresh-command-window)))
+
+(define (paint-completion-select-list select-list command)
+  (let ((win (app-window-curses-win result-window)))
+    (wclear win)
+    (wattron win (A-BOLD))
+    (mvwaddstr win 0 0 
+	       (string-append "Possible completions for " command))
+    (wattrset win (A-NORMAL))
+    (paint-result-buffer (paint-selection-list-at select-list 0 2))
+    (refresh-result-window)))
 
 (define (offer-completions command)
-  (debug-message "offer-completions " command)
+  (let* ((tokens/cursor-list (tokenize-command command))
+	 (command (caar tokens/cursor-list)))
+    (call-with-values
+	(lambda ()
+	  (find-token-with-cursor tokens/cursor-list))
+      (lambda (prefix arg-pos)
+	;; hook in completer functions here
+	(let ((completions (command-mode-complete command)))
+	  (if (= (length completions) 1)
+	      (begin
+		(complete-in-command-buffer command (car completions))
+		#f)
 	      (let ((select-list 
 		     (completions->select-list 
-	  (completions-for (command-completions) command))))
-    (wclear (app-window-curses-win result-window))
-    (paint-result-buffer (paint-selection-list select-list))
-    (refresh-result-window)))
+		      completions (- (result-buffer-num-lines result-buffer) 3))))
+		(paint-completion-select-list select-list command)
+		select-list)))))))
+
+(define (find-token-with-cursor tokens/cursor-list)
+  (let lp ((lst tokens/cursor-list) (i 0))
+    (cond
+     ((null? lst)
+      (values #f i))
+     ((cdar lst)
+      (values (caar lst) i))
+     (else
+      (lp (cdr lst) (+ i 1))))))
+
+(define (command-token-delimiter? c)
+  (char-set-contains? char-set:whitespace c))
+
+(define (skip-delimters delimiter? chars)
+  (let lp ((chars chars) (i 0))
+    (cond
+     ((null? chars) (values '() i))
+     ((delimiter? (car chars))
+      (lp (cdr chars) (+ i 1)))
+     (else (values chars i)))))
+
+(define (tokenize-command command)
+  (let ((cursor-pos (- (buffer-pos-col command-buffer) 2))) ;; don't ask
+    (let lp ((chars (string->list command))
+	     (token "")
+	     (tokens '())
+	     (i 0))
+      (cond 
+       ((null? chars)
+	(reverse (cons (cons token (= i cursor-pos)) tokens)))
+       ((command-token-delimiter? (car chars))
+	(call-with-values
+	    (lambda ()
+	      (skip-delimters command-token-delimiter? chars))
+	  (lambda (rest skipped)
+	    (lp rest "" (cons (cons token (= i cursor-pos)) tokens)
+		(+ i skipped)))))
+       (else
+	(lp (cdr chars) (string-append token (string (car chars)))
+	    tokens (+ i 1)))))))
 
 (define-record-type standard-result-obj standard-result-obj
   (make-standard-result-obj cursor-pos-y