commander-s/scheme/nuit-engine.scm

946 lines
28 KiB
Scheme
Raw Normal View History

(define-syntax when
(syntax-rules ()
((_ ?test ?do-this ...)
(if ?test
(begin ?do-this ... (values))
(values)))))
2004-10-10 09:22:25 -04:00
2005-06-04 05:43:22 -04:00
(define-syntax with-lock
(syntax-rules ()
((_ lock exp ...)
(begin
(obtain-lock lock)
(let ((val (begin exp ...)))
(release-lock lock)
val)))))
2005-05-23 09:03:45 -04:00
;; mode of the command buffer
(define *command-buffer-mode* 'scheme)
(define (command-buffer-in-scheme-mode?)
(eq? *command-buffer-mode* 'scheme))
(define (command-buffer-in-command-mode?)
(eq? *command-buffer-mode* 'command))
(define (enter-scheme-mode!)
(set! *command-buffer-mode* 'scheme))
(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)
;; History
2004-09-20 04:09:54 -04:00
(define history-pos 0)
(define the-history (make-empty-history))
(define (history) the-history)
(define *current-history-item* #f)
2004-09-20 04:09:54 -04:00
(define (current-history-item)
*current-history-item*)
(define-record-type history-entry :history-entry
(make-history-entry command args viewer)
history-entry?
(command history-entry-command)
(args history-entry-args)
(viewer history-entry-viewer set-history-entry-viewer!))
(define (current-history-entry-selector-maker selector)
(lambda ()
(cond
((current-history-item)
=> (lambda (entry)
(selector (entry-data entry))))
(else #f))))
2004-09-20 04:09:54 -04:00
(define active-command
(current-history-entry-selector-maker history-entry-command))
2004-10-10 09:22:25 -04:00
(define active-command-arguments
(current-history-entry-selector-maker history-entry-args))
(define current-viewer
(current-history-entry-selector-maker history-entry-viewer))
(define (update-current-viewer! new-viewer)
(cond
((current-history-item)
=> (lambda (entry)
(set-history-entry-viewer! (entry-data entry) new-viewer)))
(else (values))))
(define (append-to-history! history-entry)
(append-history-item! the-history history-entry)
(set! *current-history-item*
(history-last-entry the-history)))
;; one step back in the history
(define (history-back!)
(cond
((and (current-history-item)
(history-prev-entry (current-history-item)))
=> (lambda (prev)
(set! *current-history-item* prev)))
(else (values))))
;; one step forward
(define (history-forward!)
(cond
((and *current-history-item*
(history-next-entry *current-history-item*))
=> (lambda (next)
(set! *current-history-item* next)))
(else (values))))
2004-10-10 09:22:25 -04:00
;;active keyboard-interrupt:
;;after each input this is set to #f.
;;If a keyboard-interrupt occurs this can be checked by looking-up this box
(define active-keyboard-interrupt #f)
;;The "user" (who extends the functionality of NUIT) has to inform NUIT
;;about which function is meant to be the receiver, when a certain
;;command is active
2004-10-10 09:22:25 -04:00
2004-09-14 07:54:00 -04:00
;;*************************************************************************
;;Actions
2004-09-14 07:54:00 -04:00
2004-10-10 09:22:25 -04:00
;;start the whole thing
(define (nuit)
2005-05-18 11:25:16 -04:00
(let ((tty-name (init-tty-debug-output!)))
(if tty-name
(begin
(display "Debug messages will be on ")
(display tty-name)
(newline))))
(with-inspecting-handler
8888
(lambda (condition)
(with-current-output-port*
(error-output-port)
(lambda ()
(display "starting remote handler for condition")
(display condition)
(newline)
(display "Please connect to port 8888")
(newline)
#t)))
run))
2004-10-10 09:22:25 -04:00
(define (toggle-buffer-focus)
(cond
((focus-on-command-buffer?)
(focus-result-buffer!)
(refresh-result-window))
(else
(focus-command-buffer!)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))))
2005-05-23 09:03:45 -04:00
(define (toggle-command/scheme-mode)
(cond
((command-buffer-in-command-mode?)
(enter-scheme-mode!))
((command-buffer-in-scheme-mode?)
(enter-command-mode!)))
(paint-command-frame-window)
(paint-command-window-contents)
(move-cursor (command-buffer) (result-buffer))
2005-05-23 09:03:45 -04:00
(refresh-command-window))
(define (handle-return-key)
(let ((command-line (cadr (reverse (buffer-text (command-buffer))))))
(debug-message "command-line " command-line)
(cond
((string=? command-line "")
(values))
((command-buffer-in-scheme-mode?)
(eval-command-in-scheme-mode command-line))
((command-buffer-in-command-mode?)
(eval-command-in-command-mode command-line))
(else
(error "Cannot handle return key" command-line)))))
(define (find-command-plugin command)
(or (find (lambda (p)
(string=? (command-plugin-command p) command))
(command-plugin-list))
standard-command-plugin))
(define (eval-command-in-command-mode command-line)
(let* ((tokens (split-command-line command-line))
(command (car tokens))
(args (cdr tokens))
(command-plugin (find-command-plugin command))
(viewer
(find/init-plugin-for-result
(with-errno-handler
((errno data)
(else data))
((command-plugin-evaluater command-plugin) command args))))
(new-entry
(make-history-entry command args viewer)))
;; FIXME, use insert here
(append-to-history! new-entry)
(signal-result-buffer-object-change)
2005-06-04 05:43:22 -04:00
(obtain-lock paint-lock)
(paint-result-window new-entry)
(refresh-result-window)
(move-cursor (command-buffer) (result-buffer))
2005-06-04 05:43:22 -04:00
(refresh-command-window)
(release-lock paint-lock)))
(define (display-error-and-continue condition more)
(let ((win (app-window-curses-win (result-window))))
(wclear win)
(wattron win (A-BOLD))
(mvwaddstr win 0 0
(string-append "I'm sorry " (user-login-name) ", "
"I'm afraid I can't do that. "
"The following error occured:"))
(wattrset win (A-NORMAL))
(let ((string-port (open-output-string)))
(display condition string-port)
(display " " string-port)
(display more)
(mvwaddstr win 5 0 (get-output-string string-port)))
(refresh-result-window)))
(define (eval-command-in-scheme-mode command-line)
(with-fatal-error-handler*
display-error-and-continue
(lambda ()
(let ((viewer
(find/init-plugin-for-result
(eval-string command-line))))
(let* ((tokens (split-command-line command-line))
(command (car tokens))
(args (cdr tokens))
(new-entry
(make-history-entry command args viewer)))
;; #### shouldn't we use some kind of insertion here?
(append-to-history! new-entry)
(signal-result-buffer-object-change)
(obtain-lock paint-lock)
(paint-result-window new-entry)
(refresh-result-window)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock))))))
;; #### crufty, and a very dumb idea
(define split-command-line string-tokenize)
2005-06-01 06:04:21 -04:00
(define (paste-selection/refresh viewer)
(add-string-to-command-buffer
(send (current-viewer)
'get-selection-as-text
(command-buffer-in-scheme-mode?) (focus-table)))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(refresh-result-window))
2005-06-01 06:04:21 -04:00
(define (paste-focus-object/refresh viewer)
(add-string-to-command-buffer
(if (command-buffer-in-command-mode?)
(send (current-viewer)
'get-selection-as-text
(command-buffer-in-scheme-mode?)
(focus-table))
(send (current-viewer) 'get-selection-as-ref (focus-table))))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(refresh-result-window))
2005-06-01 06:04:21 -04:00
2005-06-14 07:20:30 -04:00
;; #### implement me
(define terminal-input-handler
(lambda ignore
'terminal-input))
;; #### implement me
(define terminal-output-handler
(lambda ignore
'terminal-output))
(define (install-signal-handlers)
(for-each
(lambda (signal)
(set-interrupt-handler signal #f))
2005-06-14 09:44:09 -04:00
(list interrupt/int
;interrupt/quit
interrupt/tstp))
2005-06-14 07:20:30 -04:00
(set-interrupt-handler signal/ttin terminal-input-handler)
(set-interrupt-handler signal/ttou terminal-output-handler))
(define (enable-tty-output-control! port)
(let ((info (copy-tty-info (tty-info port))))
(set-tty-info:local-flags
info
2005-06-14 09:44:09 -04:00
(bitwise-ior (tty-info:local-flags info)
2005-06-14 07:20:30 -04:00
ttyl/ttou-signal))
(set-tty-info/now port info)))
(define (process-group-leader?)
(= (process-group) (pid)))
;; handle input
(define (run)
2005-06-14 07:20:30 -04:00
(save-initial-tty-info! (current-input-port))
2005-06-14 09:44:09 -04:00
(autoreap-policy #f)
(init-screen)
(init-windows!)
(clear)
2005-06-14 07:20:30 -04:00
(if (not (process-group-leader?))
(become-session-leader))
(set-tty-process-group (current-input-port) (pid))
(init-executables-completion-set!)
2005-06-14 07:20:30 -04:00
(enable-tty-output-control! (current-output-port))
2005-06-03 07:44:53 -04:00
;; init joblist
(let ((statistics-channel (spawn-joblist-surveillant)))
(spawn
(lambda ()
(let lp ((stats (cml-receive statistics-channel)))
(debug-message "statistics update " stats)
2005-06-04 05:43:22 -04:00
(obtain-lock paint-lock)
(paint-command-frame-window)
(paint-job-status-list stats)
(paint-command-window-contents)
(wrefresh (app-window-curses-win (command-frame-window)))
(move-cursor (command-buffer) (result-buffer))
2005-06-04 05:43:22 -04:00
(refresh-command-window)
(release-lock paint-lock)
2005-06-03 07:44:53 -04:00
(lp (cml-receive statistics-channel))))))
;;Loop
(paint)
(let loop ((ch (wait-for-input)) (c-x-pressed? #f)
(completion-selector #f))
(cond
;; Ctrl-x -> wait for next input
((= ch key-control-x)
(loop (wait-for-input) #t completion-selector))
((and (focus-on-result-buffer?) completion-selector)
(let ((new-selector (completion-selector ch)))
(loop (wait-for-input) c-x-pressed? new-selector)))
;; tab pressed twice, select completion using select-list
((and (focus-on-command-buffer?)
completion-selector
(= ch key-tab))
(focus-result-buffer!)
(loop (wait-for-input) #f completion-selector))
;; tab is pressed in the first place, offer completions
((and (focus-on-command-buffer?)
(= ch key-tab))
(let ((maybe-selector
(offer-completions (last (buffer-text (command-buffer))))))
(loop (wait-for-input) #f maybe-selector)))
2005-05-23 09:03:45 -04:00
;; F7 toggle scheme-mode / command-mode (FIXME: find a better key)
((= ch key-f7)
2005-05-23 09:03:45 -04:00
(toggle-command/scheme-mode)
(loop (wait-for-input) #f #f))
2005-05-23 09:03:45 -04:00
((= ch key-f8)
(show-shell-screen)
(paint)
(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 #f))
;; C-x p --- insert selection
2005-06-01 06:04:21 -04:00
((and c-x-pressed? (current-history-item)
(= ch 112))
2005-06-01 06:04:21 -04:00
(paste-selection/refresh (current-viewer))
(loop (wait-for-input) #f #f))
2005-06-01 06:04:21 -04:00
;; C-x P --- insert focus object(s)
((and c-x-pressed? (current-history-item)
(= ch 80))
(paste-focus-object/refresh (current-viewer))
(loop (wait-for-input) #f #f))
((and c-x-pressed? (focus-on-result-buffer?))
(update-current-viewer!
(send (current-viewer)
'key-press ch key-control-x))
(loop (wait-for-input) #f #f))
;; C-x r --- redo
((and c-x-pressed? (focus-on-command-buffer?)
(= ch 114))
(debug-message "Eric should re-implement redo..."))
((= ch key-f1)
(endwin))
((= ch key-f2)
(paint)
(loop (wait-for-input) c-x-pressed? #f))
;; forward in result history
((= ch key-npage)
(history-forward!)
2005-06-04 05:43:22 -04:00
(obtain-lock paint-lock)
(when (current-history-item)
(paint-active-command-window)
(signal-result-buffer-object-change)
(paint-result-window (entry-data (current-history-item))))
(refresh-result-window)
2005-06-04 05:43:22 -04:00
(release-lock paint-lock)
(loop (wait-for-input) c-x-pressed? #f))
;; back in result history
((= ch key-ppage)
(history-back!)
2005-06-04 05:43:22 -04:00
(obtain-lock paint-lock)
(when (current-history-item)
(paint-active-command-window)
(signal-result-buffer-object-change)
(paint-result-window (entry-data (current-history-item))))
(refresh-result-window)
2005-06-04 05:43:22 -04:00
(release-lock paint-lock)
(loop (wait-for-input) c-x-pressed? #f))
((and (focus-on-command-buffer?) (= ch 10))
(input (command-buffer) ch)
2005-06-04 05:43:22 -04:00
(obtain-lock paint-lock)
(werase (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)
2005-06-04 05:43:22 -04:00
(release-lock paint-lock)
(handle-return-key)
(loop (wait-for-input) c-x-pressed? #f))
(else
(cond
((focus-on-result-buffer?)
(when (current-history-item)
(update-current-viewer!
(send (current-viewer)
'key-press ch c-x-pressed?))
2005-06-04 05:43:22 -04:00
(obtain-lock paint-lock)
(paint-result-window (entry-data (current-history-item)))
(move-cursor (command-buffer) (result-buffer))
2005-06-04 05:43:22 -04:00
(refresh-result-window)
(release-lock paint-lock))
(loop (wait-for-input) #f #f))
(else
(input (command-buffer) ch)
2005-06-04 05:43:22 -04:00
(obtain-lock paint-lock)
(werase (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)
2005-06-04 05:43:22 -04:00
(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
2005-06-04 05:43:22 -04:00
(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))))
2005-05-23 09:03:45 -04:00
(define (paint-command-buffer-mode-indicator)
(let ((mode-string
(string-append
"[ "
(if (command-buffer-in-command-mode?)
"Command"
"Scheme")
" ]")))
(mvwaddstr
(app-window-curses-win (command-frame-window))
2005-05-23 09:03:45 -04:00
0
(- (- (app-window-width (command-frame-window))
2005-05-23 09:03:45 -04:00
(string-length mode-string))
2)
mode-string)))
(define (paint-command-frame-window)
(box (app-window-curses-win (command-frame-window))
(ascii->char 0) (ascii->char 0))
2005-05-23 09:03:45 -04:00
(paint-command-buffer-mode-indicator)
2005-06-03 07:44:53 -04:00
(paint-job-status-list)
(wrefresh (app-window-curses-win (command-frame-window))))
2005-06-03 07:44:53 -04:00
(define paint-job-status-list
(let ((latest-statistics (initial-job-statistics)))
(lambda args
(let-optionals args
((statistics latest-statistics))
(let* ((stat-item (lambda (text number)
(string-append text (number->string number))))
(stat
(string-join
(map
(lambda (status.count)
(case (car status.count)
((running) (stat-item "run:" (cdr status.count)))
((ready) (stat-item "ready:" (cdr status.count)))
2005-06-14 07:20:30 -04:00
((stopped) (stat-item "stop:" (cdr status.count)))
2005-06-03 07:44:53 -04:00
((new-output) (stat-item "out:" (cdr status.count)))
((waiting-for-input) (stat-item "in:" (cdr status.count)))))
statistics)))
(line (string-append "[ " stat " ]")))
(set! latest-statistics statistics)
(mvwaddstr
(app-window-curses-win (command-frame-window))
(- (app-window-height (command-frame-window)) 1)
(- (- (app-window-width (command-frame-window))
2005-06-03 07:44:53 -04:00
(string-length line))
2)
line))))))
(define (paint-command-window-contents)
(set-buffer-num-lines! (command-buffer)
(- (app-window-height (command-window)) 2))
(set-buffer-num-cols! (command-buffer)
(- (app-window-width (command-window)) 3))
(werase (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer)))
2005-05-18 14:55:51 -04:00
(define (refresh-command-window)
(wrefresh (app-window-curses-win (command-window))))
(define (paint-result-frame-window)
(let ((win (app-window-curses-win (result-frame-window))))
(wclear win)
(box win (ascii->char 0) (ascii->char 0))
(wrefresh win)))
(define (paint-result-window entry)
(let ((win (app-window-curses-win (result-window))))
(wclear win)
(send (history-entry-viewer entry)
'paint win (result-buffer) (focus-on-result-buffer?))))
(define (refresh-result-window)
(wrefresh (app-window-curses-win (result-window))))
2004-10-10 09:22:25 -04:00
(define (paint-result/command-buffer history-entry)
(paint-result-window history-entry)
(paint-active-command-window)
(scroll-command-buffer)
(paint-command-window-contents)
(move-cursor (command-buffer) (result-buffer))
(refresh-result-window)
(refresh-command-window))
(define (paint)
(paint-bar-1)
(paint-command-frame-window)
(paint-command-window-contents)
(paint-active-command-window)
(paint-result-frame-window)
;(paint-result-window)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(refresh-result-window))
(define (wait-for-input)
(noecho)
(keypad (app-window-curses-win (bar-1)) #t)
(set! active-keyboard-interrupt #f)
(let ((ch (wgetch (app-window-curses-win (bar-1)))))
(echo)
ch))
(define (find/init-plugin-for-result result)
(cond
;; #### a hack
((null? result)
(make-standard-viewer result (result-buffer)))
((determine-plugin-by-type result)
=> (lambda (view-plugin)
2005-05-31 09:14:55 -04:00
((view-plugin-constructor view-plugin)
result (result-buffer))))
(else
(make-standard-viewer result (result-buffer)))))
2004-10-10 09:22:25 -04:00
;;scroll buffer after one command was entered
(define (scroll-command-buffer)
(set-buffer-pos-line! (command-buffer)
(+ (buffer-pos-line (command-buffer)) 1))
(set-buffer-pos-col! (command-buffer) 2))
2004-09-20 04:09:54 -04:00
(define (determine-plugin-by-type result)
(find (lambda (r)
((view-plugin-type-predicate r) result))
(view-plugin-list)))
;;Management of the upper buffer
;;add a char to the buffer
(define (add-to-command-buffer ch)
(let* ((text (buffer-text (command-buffer)))
(last-pos (- (length text) 1))
(old-last-el (list-ref text last-pos))
(old-rest (sublist text 0 last-pos))
(before-ch (substring old-last-el 0
2005-06-07 16:54:22 -04:00
(max 0 (- (buffer-pos-col (command-buffer)) 2))))
(after-ch (substring old-last-el
(max 0 (- (buffer-pos-col (command-buffer)) 2))
(string-length old-last-el)))
(new-last-el (string-append before-ch
(string (ascii->char ch))
after-ch)))
(set-buffer-text! (command-buffer)
(append old-rest (list new-last-el)))
(set-buffer-pos-col! (command-buffer)
(+ (buffer-pos-col (command-buffer)) 1))))
2004-09-14 07:54:00 -04:00
;;add a string to the buffer
2005-05-17 16:19:53 -04:00
(define (add-string-to-command-buffer string)
(let loop ((str string))
(if (string=? str "")
(values)
(let ((first-ch (string-ref str 0)))
(add-to-command-buffer (char->ascii first-ch))
(loop (substring str 1 (string-length str)))))))
;;; FIXME: I guess s48 knows a better way to do this (see ,inspect)
(define (maybe-shorten-string string width)
(if (> (string-length string) width)
(string-append (substring string 0 (- width 3))
"...")
string))
(define (paint-active-command-window)
(let ((win (app-window-curses-win (active-command-window)))
(width (app-window-width (active-command-window))))
(wclear win)
(box win (ascii->char 0) (ascii->char 0))
(cond
((current-history-item)
=> (lambda (entry)
(mvwaddstr win 1 2
(maybe-shorten-string
(history-entry-command (entry-data entry)) width)))))
(wrefresh win)))
;;Cursor
;;move cursor to the corrct position
(define (move-cursor command-buffer result-buffer)
(cond
((focus-on-command-buffer?)
(cursor-right-pos
(app-window-curses-win (command-window))
command-buffer))
(else
(compute-y-x result-buffer)
(wmove (app-window-curses-win (result-window))
(result-buffer-y result-buffer)
(result-buffer-x result-buffer))
(wrefresh (app-window-curses-win (result-window))))))
2004-09-14 07:54:00 -04:00
;;compue pos-x and pos-y
(define (compute-y-x result-buffer)
(let ((pos-result (result-buffer-line result-buffer))
(pos-result-col (result-buffer-column result-buffer))
(result-lines (result-buffer-num-lines result-buffer)))
(if (>= pos-result result-lines)
(set-result-buffer-y! result-buffer result-lines)
(set-result-buffer-y! result-buffer pos-result))
(set-result-buffer-x! result-buffer pos-result-col)))
2004-09-14 07:54:00 -04:00
2005-05-17 16:19:53 -04:00
(define (sublist l pos k)
(let ((tmp (list-tail l pos)))
(reverse (list-tail (reverse tmp)
(- (length tmp) k)))))
2004-10-10 09:22:25 -04:00
;;When NUIT is closed the state has to be restored, in order to let the
;;user start again from scratch
2005-05-17 16:19:53 -04:00
(define (restore-state)
(set! history '())
(set! history-pos 0)
(set! active-keyboard-interrupt #f))
2004-10-10 09:22:25 -04:00
(define (get-param-as-str param-lst)
(let loop ((lst param-lst)
(str ""))
(if (null? lst)
str
(loop (cdr lst)
(string-append str " " (car lst))))))
2004-10-10 09:22:25 -04:00
(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)
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
2005-06-04 05:43:22 -04:00
(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)
(set-buffer-text! (command-buffer)
(append
(drop-right (buffer-text (command-buffer)) 1)
(list line)))
(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-selection-list-at select-list 0 2
win (result-buffer) (focus-on-result-buffer?))
(refresh-result-window)))
(define (completer-function-for-command command)
2005-06-13 07:04:49 -04:00
(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 (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)))))))
(define (make-completion-selector select-list completions
command arg arg-pos)
(lambda (key)
(cond
((= key 10)
(focus-command-buffer!)
(call-with-values
(lambda ()
(assemble-line-with-completion
command arg arg-pos
(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)))))))