Make Commander S use the new completion code and move this cruft to a
separate module.
This commit is contained in:
eknauel
parent
41b8e1dde9
commit
8c5de5ee27
|
|
@ -0,0 +1,225 @@
|
|||
;;; #### 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))))))))
|
||||
|
||||
|
|
@ -29,9 +29,6 @@
|
|||
(define (enter-command-mode!)
|
||||
(set! *command-buffer-mode* 'command))
|
||||
|
||||
(define executable-completions-lock (make-lock))
|
||||
(define executable-completions #f)
|
||||
|
||||
(define key-control-x 24)
|
||||
(define key-o 111)
|
||||
(define key-tab 9)
|
||||
|
|
@ -465,22 +462,6 @@
|
|||
(release-lock paint-lock)
|
||||
(loop (wait-for-input) c-x-pressed? #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)))))))
|
||||
|
||||
(define (paint-bar-1)
|
||||
(mvwaddstr (app-window-curses-win (bar-1)) 0 1 "Commander S")
|
||||
(wrefresh (app-window-curses-win (bar-1))))
|
||||
|
|
@ -716,84 +697,6 @@
|
|||
completions)
|
||||
num-lines))
|
||||
|
||||
(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 (complete-with-filesystem-objects filter partial-name)
|
||||
(if (and (file-exists? partial-name) (file-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)
|
||||
(or (file-executable? file) (file-directory? file)))
|
||||
partial-name))
|
||||
|
||||
(define (complete-files/path partial-name)
|
||||
(complete-with-filesystem-objects
|
||||
(lambda (file) #t) partial-name))
|
||||
|
||||
(define (command-completer command prefix args args-pos)
|
||||
(debug-message "command-mode-completer" prefix "|" args "|" args-pos)
|
||||
(cond
|
||||
((command-contains-path? prefix)
|
||||
;; #### FIXME ignore errors here?
|
||||
(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))))))
|
||||
|
||||
(define (file-completer command prefix args args-pos)
|
||||
(if (zero? (string-length prefix))
|
||||
(complete-files/path prefix)
|
||||
(complete-files/path (expand-file-name prefix (cwd)))))
|
||||
|
||||
(define (assemble-line-with-completion command arg arg-pos completion)
|
||||
(debug-message "assemble-line-with-completion "
|
||||
command "," arg "," arg-pos "," completion)
|
||||
(let ((string-append* (lambda (s t)
|
||||
(if (string=? s "")
|
||||
t
|
||||
(string-append s " " t)))))
|
||||
(let lp ((tokens (cons command arg))
|
||||
(arg-count 0)
|
||||
(cursor-pos 0)
|
||||
(line ""))
|
||||
(cond
|
||||
((null? tokens)
|
||||
(values line (+ 2 cursor-pos)))
|
||||
((= arg-count arg-pos)
|
||||
(lp (cdr tokens)
|
||||
(+ arg-count 1)
|
||||
(+ cursor-pos (string-length completion))
|
||||
(string-append* line completion)))
|
||||
(else
|
||||
(lp (cdr tokens)
|
||||
(+ arg-count 1)
|
||||
(+ 1 (+ cursor-pos (string-length (car tokens))))
|
||||
(string-append* line (car tokens))))))))
|
||||
|
||||
(define (display-completed-line line cursor-pos)
|
||||
(debug-message "display-completed-line " line "," cursor-pos)
|
||||
(set-buffer-pos-col! (command-buffer) cursor-pos)
|
||||
|
|
@ -818,128 +721,65 @@
|
|||
win (result-buffer) (focus-on-result-buffer?))
|
||||
(refresh-result-window)))
|
||||
|
||||
(define (completer-function-for-command command)
|
||||
(let ((alist
|
||||
(map (lambda (p)
|
||||
(cons (command-plugin-command p)
|
||||
(command-plugin-completer p)))
|
||||
(command-plugin-list))))
|
||||
(cond
|
||||
((assoc command alist) => cdr)
|
||||
(else #f))))
|
||||
|
||||
(define (call-completer command args prefix arg-pos)
|
||||
(cond
|
||||
((= 0 arg-pos)
|
||||
(command-completer command prefix args arg-pos))
|
||||
((completer-function-for-command command)
|
||||
=> (lambda (completer)
|
||||
(completer command prefix args arg-pos)))
|
||||
(else
|
||||
(file-completer command prefix args arg-pos))))
|
||||
(define (current-cursor-index)
|
||||
;; #### No, I will not comment on this.
|
||||
(- (buffer-pos-col (command-buffer)) 2))
|
||||
|
||||
(define (offer-completions command)
|
||||
(let* ((tokens/cursor-list (tokenize-command command))
|
||||
(args (map car (cdr tokens/cursor-list)))
|
||||
(command (caar tokens/cursor-list)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(find-token-with-cursor tokens/cursor-list))
|
||||
(lambda (prefix arg-pos)
|
||||
;; #### FIXME
|
||||
(if (not prefix)
|
||||
(error "could not determine token with cursor position"
|
||||
tokens/cursor-list command
|
||||
(- (buffer-pos-col (command-buffer)) 2)))
|
||||
(let ((completions
|
||||
(call-completer command args
|
||||
prefix arg-pos)))
|
||||
(if (= (length completions) 1)
|
||||
(begin
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(assemble-line-with-completion
|
||||
command args arg-pos (car completions)))
|
||||
display-completed-line)
|
||||
#f)
|
||||
(let* ((select-list
|
||||
(completions->select-list
|
||||
completions
|
||||
(- (result-buffer-num-lines (result-buffer)) 3)))
|
||||
(selector
|
||||
(make-completion-selector
|
||||
select-list completions
|
||||
command args arg-pos)))
|
||||
(paint-completion-select-list select-list command)
|
||||
(move-cursor (command-buffer) (result-buffer))
|
||||
(refresh-command-window)
|
||||
selector)))))))
|
||||
(debug-message "offer-completions '" command "'")
|
||||
(let ((completion-info (complete command (current-cursor-index))))
|
||||
(if (not completion-info)
|
||||
(begin
|
||||
;; #### the completion mechanism was too confused to do anything
|
||||
;; #### beep or so
|
||||
#f)
|
||||
(destructure
|
||||
(((completions cursor-index to-complete cmdln) completion-info))
|
||||
(cond
|
||||
((string? completions)
|
||||
;; #### don't ask
|
||||
(display-completed-line completions (+ 2 cursor-index))
|
||||
#f)
|
||||
((list? completions)
|
||||
(let* ((select-list
|
||||
(completions->select-list
|
||||
completions
|
||||
(- (result-buffer-num-lines (result-buffer)) 3)))
|
||||
(selector
|
||||
(make-completion-selector select-list completions
|
||||
cmdln to-complete)))
|
||||
(paint-completion-select-list select-list command)
|
||||
(move-cursor (command-buffer) (result-buffer))
|
||||
(refresh-command-window)
|
||||
selector))
|
||||
(else
|
||||
(error "COMPLETE returned an unexpected value"
|
||||
completions)))))))
|
||||
|
||||
(define (make-completion-selector select-list completions
|
||||
command arg arg-pos)
|
||||
(define (make-completion-selector select-list completions
|
||||
cmdln to-complete)
|
||||
(lambda (key)
|
||||
(cond
|
||||
((= key 10)
|
||||
(focus-command-buffer!)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(assemble-line-with-completion
|
||||
command arg arg-pos
|
||||
(let ((completion
|
||||
(select-list-selected-entry select-list)))
|
||||
display-completed-line)
|
||||
#f)
|
||||
((or (select-list-navigation-key? key)
|
||||
(select-list-marking-key? key))
|
||||
(let ((new-select-list
|
||||
(select-list-handle-key-press select-list key)))
|
||||
(paint-completion-select-list
|
||||
new-select-list (last (buffer-text (command-buffer))))
|
||||
(make-completion-selector
|
||||
new-select-list completions command arg arg-pos)))
|
||||
(else
|
||||
;; #### FIXME we loose a character this way
|
||||
(focus-command-buffer!)
|
||||
#f))))
|
||||
|
||||
(define (find-token-with-cursor tokens/cursor-list)
|
||||
(debug-message "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)))))))
|
||||
|
||||
(focus-command-buffer!)
|
||||
;; #### No, I will not comment on this.
|
||||
(display-completed-line
|
||||
(unparse-command-line
|
||||
(assemble-with-completion
|
||||
cmdln to-complete completion))
|
||||
(+ 2 (calculate-cursor-index to-complete completion)))
|
||||
#f))
|
||||
((or (select-list-navigation-key? key)
|
||||
(select-list-marking-key? key))
|
||||
(let ((new-select-list
|
||||
(select-list-handle-key-press select-list key)))
|
||||
(paint-completion-select-list
|
||||
new-select-list (last (buffer-text (command-buffer))))
|
||||
(make-completion-selector
|
||||
new-select-list completions cmdln to-complete)))
|
||||
(else
|
||||
;; #### FIXME we loose a character this way
|
||||
(focus-command-buffer!)
|
||||
#f))))
|
||||
|
|
|
|||
|
|
@ -462,6 +462,40 @@
|
|||
thread-fluids)
|
||||
(files complete))
|
||||
|
||||
;;; standard completion mechanism
|
||||
|
||||
(define-interface completer-interface
|
||||
(export init-executables-completion-set!
|
||||
complete
|
||||
calculate-cursor-index
|
||||
assemble-with-completion))
|
||||
|
||||
(define-structure completer completer-interface
|
||||
(open scheme
|
||||
(subset scsh
|
||||
(file-name-directory glob with-cwd cwd
|
||||
absolute-file-name expand-file-name
|
||||
file-exists? file-directory? file-executable?
|
||||
directory-files getenv))
|
||||
threads
|
||||
locks
|
||||
signals
|
||||
handle
|
||||
conditions
|
||||
destructuring
|
||||
(subset srfi-1 (filter-map))
|
||||
srfi-13
|
||||
srfi-14
|
||||
|
||||
tty-debug
|
||||
completion-sets
|
||||
plugin
|
||||
plugin-host
|
||||
command-line-lexer
|
||||
command-line-parser
|
||||
command-line-absyn)
|
||||
(files completer))
|
||||
|
||||
;;; console
|
||||
|
||||
(define-interface console-interface
|
||||
|
|
@ -602,7 +636,12 @@
|
|||
|
||||
redirection?
|
||||
redirection-op
|
||||
redirection-dest))
|
||||
redirection-dest
|
||||
|
||||
to-complete?
|
||||
to-complete-prefix
|
||||
to-complete-without-prefix?
|
||||
to-complete-pos))
|
||||
|
||||
(define-interface command-line-absyn-constructors-interface
|
||||
(export
|
||||
|
|
@ -675,7 +714,6 @@
|
|||
signals
|
||||
handle
|
||||
rt-modules
|
||||
(modify ncurses (hide filter))
|
||||
srfi-1
|
||||
srfi-6
|
||||
srfi-13
|
||||
|
|
@ -689,11 +727,14 @@
|
|||
(send cml-send)
|
||||
(receive cml-receive)))
|
||||
let-opt
|
||||
destructuring
|
||||
|
||||
(modify ncurses (hide filter))
|
||||
app-windows
|
||||
initial-tty
|
||||
nuit-windows
|
||||
|
||||
command-line-parser
|
||||
focus-table
|
||||
result-buffer-changes
|
||||
nuit-eval/focus-table
|
||||
|
|
@ -706,6 +747,7 @@
|
|||
history
|
||||
handle-fatal-error
|
||||
completion-sets
|
||||
completer
|
||||
select-list
|
||||
jobs
|
||||
run-jobs
|
||||
|
|
|
|||
Loading…
Reference in New Issue