894 lines
27 KiB
Scheme
894 lines
27 KiB
Scheme
(define-syntax when
|
|
(syntax-rules ()
|
|
((_ ?test ?do-this ...)
|
|
(if ?test
|
|
(begin ?do-this ... (values))
|
|
(values)))))
|
|
|
|
(define-syntax with-lock
|
|
(syntax-rules ()
|
|
((_ lock exp ...)
|
|
(begin
|
|
(obtain-lock lock)
|
|
(let ((val (begin exp ...)))
|
|
(release-lock lock)
|
|
val)))))
|
|
|
|
;; configurable options
|
|
|
|
(define-option 'main 'switch-command-buffer-mode-key key-f7)
|
|
|
|
;; configurable options
|
|
|
|
(define-option 'main 'switch-command-buffer-mode-key key-f7)
|
|
|
|
;; configurable options
|
|
|
|
(define-option 'main 'switch-command-buffer-mode-key key-f7)
|
|
|
|
;; mode of the command buffer
|
|
(define-option 'main 'initial-command-mode 'command)
|
|
|
|
(define *command-buffer-mode*)
|
|
|
|
(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 key-control-x 24)
|
|
(define key-o 111)
|
|
(define key-tab 9)
|
|
|
|
;; History
|
|
|
|
(define history-pos 0)
|
|
(define the-history (make-empty-history))
|
|
|
|
(define (history) the-history)
|
|
|
|
(define *current-history-item* #f)
|
|
|
|
(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))))
|
|
|
|
(define active-command
|
|
(current-history-entry-selector-maker history-entry-command))
|
|
|
|
(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)
|
|
(if (not (eq? (history-entry-viewer (entry-data entry))
|
|
new-viewer))
|
|
(append-to-history!
|
|
(make-history-entry #f '() 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))))
|
|
|
|
;;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
|
|
|
|
;;*************************************************************************
|
|
;;Actions
|
|
|
|
;;start the whole thing
|
|
(define (nuit)
|
|
(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))
|
|
|
|
(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))))
|
|
|
|
(define (current-command-line)
|
|
(let ((entered (last (buffer-text (command-buffer)))))
|
|
(if (string=? entered "")
|
|
#f
|
|
entered)))
|
|
|
|
(define (replace-current-command-line! text)
|
|
(set-buffer-text!
|
|
(command-buffer)
|
|
(reverse
|
|
(cons text
|
|
(cdr (reverse (buffer-text (command-buffer))))))))
|
|
|
|
(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))
|
|
(refresh-command-window))
|
|
|
|
;; assumes we are in command mode
|
|
(define (toggle-command/scheme-mode-with-conversion)
|
|
(cond
|
|
((current-command-line)
|
|
=> (lambda (cmdln)
|
|
(cond
|
|
((lex/parse-partial-command-line cmdln #f)
|
|
=> (lambda (parsed)
|
|
(let ((scheme-str
|
|
(write-to-string
|
|
(compile-command-line parsed))))
|
|
(replace-current-command-line! scheme-str)
|
|
(enter-scheme-mode!)
|
|
(set-buffer-pos-col! (command-buffer)
|
|
(+ 2 (string-length scheme-str)))
|
|
(paint-command-frame-window)
|
|
(paint-command-window-contents)
|
|
(move-cursor (command-buffer) (result-buffer))
|
|
(refresh-command-window))))
|
|
(else (values)))))
|
|
(else (values))))
|
|
|
|
(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)
|
|
(with-fatal-error-handler*
|
|
display-error-and-continue
|
|
(lambda ()
|
|
(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-inspector-handler
|
|
(lambda ()
|
|
((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)
|
|
(obtain-lock paint-lock)
|
|
(paint)
|
|
(paint-result-window (entry-data (current-history-item)))
|
|
(refresh-result-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 (process-scheme-command command-line)
|
|
(receive (command args) (split-scheme-command-line command-line)
|
|
(let* ((viewer
|
|
(find/init-plugin-for-result
|
|
(with-inspector-handler
|
|
(lambda ()
|
|
(eval-scheme-command command args)))))
|
|
(new-entry
|
|
(make-history-entry command args viewer)))
|
|
(append-to-history! new-entry)
|
|
(signal-result-buffer-object-change)
|
|
(obtain-lock paint-lock)
|
|
(paint-active-command-window)
|
|
(paint-result-window new-entry)
|
|
(refresh-result-window)
|
|
(move-cursor (command-buffer) (result-buffer))
|
|
(refresh-command-window)
|
|
(release-lock paint-lock))))
|
|
|
|
(define (eval-command-in-scheme-mode command-line)
|
|
(if (scheme-command-line? command-line)
|
|
(process-scheme-command command-line)
|
|
(let* ((viewer
|
|
(find/init-plugin-for-result
|
|
(with-inspector-handler
|
|
(lambda ()
|
|
(eval-string command-line)))))
|
|
(new-entry
|
|
(make-history-entry command-line '() 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-active-command-window)
|
|
(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)
|
|
|
|
(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))
|
|
|
|
(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))
|
|
|
|
;; #### 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))
|
|
(list interrupt/int
|
|
;interrupt/quit
|
|
interrupt/tstp))
|
|
(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
|
|
(bitwise-ior (tty-info:local-flags info)
|
|
ttyl/ttou-signal))
|
|
(set-tty-info/now port info)))
|
|
|
|
(define (process-group-leader?)
|
|
(= (process-group) (pid)))
|
|
|
|
;; handle input
|
|
(define (run)
|
|
(ignore-signal signal/ttou)
|
|
(save-initial-tty-info! (current-input-port))
|
|
|
|
(init-screen)
|
|
(init-windows!)
|
|
(read-config-file!)
|
|
(set! *command-buffer-mode* (config 'main 'initial-command-mode))
|
|
|
|
(set-evaluation-package! 'nuit-eval)
|
|
|
|
(clear)
|
|
|
|
(if (not (process-group-leader?))
|
|
(become-session-leader))
|
|
|
|
(set-tty-process-group (current-input-port) (pid))
|
|
|
|
(init-executables-completion-set!)
|
|
(enable-tty-output-control! (current-output-port))
|
|
|
|
;; init joblist
|
|
(let ((statistics-channel (spawn-joblist-surveillant)))
|
|
(spawn
|
|
(lambda ()
|
|
(let lp ((stats (cml-receive statistics-channel)))
|
|
(debug-message "statistics update " stats)
|
|
(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))
|
|
(refresh-command-window)
|
|
(release-lock paint-lock)
|
|
(lp (cml-receive statistics-channel))))))
|
|
|
|
(paint)
|
|
(let loop ((ch (wait-for-input))
|
|
(c-x-pressed? #f))
|
|
|
|
(cond
|
|
(maybe-modal-window
|
|
(if (maybe-modal-window ch)
|
|
(begin
|
|
(close-modal-window!)
|
|
(paint)
|
|
(when (current-history-item)
|
|
(paint-result-window (entry-data (current-history-item)))
|
|
(refresh-result-window))))
|
|
(loop (wait-for-input) c-x-pressed?))
|
|
;; Ctrl-x -> wait for next input
|
|
((= ch key-control-x)
|
|
(loop (wait-for-input) #t))
|
|
|
|
;; tab is pressed, offer completions
|
|
((and (focus-on-command-buffer?)
|
|
(command-buffer-in-command-mode?)
|
|
(= ch key-tab))
|
|
(offer-completions (last (buffer-text (command-buffer))))
|
|
(loop (wait-for-input) #f))
|
|
|
|
((and (focus-on-command-buffer?)
|
|
(command-buffer-in-command-mode?)
|
|
c-x-pressed?
|
|
(= ch (config 'main 'switch-command-buffer-mode-key)))
|
|
(toggle-command/scheme-mode-with-conversion)
|
|
(loop (wait-for-input) #f))
|
|
|
|
((= ch (config 'main 'switch-command-buffer-mode-key))
|
|
(toggle-command/scheme-mode)
|
|
(loop (wait-for-input) #f))
|
|
|
|
((= ch key-end)
|
|
(show-shell-screen)
|
|
(paint)
|
|
(loop (wait-for-input) #f))
|
|
|
|
;; C-x o --- toggle buffer focus
|
|
((and c-x-pressed? (= ch key-o))
|
|
(toggle-buffer-focus)
|
|
(loop (wait-for-input) #f))
|
|
|
|
;; C-x p --- insert selection
|
|
((and c-x-pressed? (current-history-item)
|
|
(= ch 112))
|
|
(paste-selection/refresh (current-viewer))
|
|
(loop (wait-for-input) #f))
|
|
|
|
;; 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))
|
|
|
|
((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))
|
|
|
|
;; C-x r --- redo
|
|
((and c-x-pressed? (focus-on-command-buffer?)
|
|
(= ch 114))
|
|
(debug-message "Eric should re-implement redo...")
|
|
(loop (wait-for-input) #f))
|
|
|
|
((= ch key-f1)
|
|
(endwin))
|
|
|
|
((= ch key-f2)
|
|
(paint)
|
|
(loop (wait-for-input) c-x-pressed?))
|
|
|
|
;; forward in result history
|
|
((= ch key-npage)
|
|
(history-forward!)
|
|
(obtain-lock paint-lock)
|
|
(when (current-history-item)
|
|
(signal-result-buffer-object-change)
|
|
(paint-active-command-window)
|
|
(paint-result-window (entry-data (current-history-item))))
|
|
(refresh-result-window)
|
|
(release-lock paint-lock)
|
|
(loop (wait-for-input) c-x-pressed?))
|
|
|
|
;; back in result history
|
|
((= ch key-ppage)
|
|
(history-back!)
|
|
(obtain-lock paint-lock)
|
|
(when (current-history-item)
|
|
(signal-result-buffer-object-change)
|
|
(paint-active-command-window)
|
|
(paint-result-window (entry-data (current-history-item))))
|
|
(refresh-result-window)
|
|
(release-lock paint-lock)
|
|
(loop (wait-for-input) c-x-pressed?))
|
|
|
|
((and (focus-on-command-buffer?) (= ch 10))
|
|
(input (command-buffer) ch)
|
|
(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)
|
|
(release-lock paint-lock)
|
|
(handle-return-key)
|
|
(loop (wait-for-input) c-x-pressed?))
|
|
|
|
(else
|
|
(cond
|
|
((focus-on-result-buffer?)
|
|
(when (current-history-item)
|
|
(update-current-viewer!
|
|
(send (current-viewer)
|
|
'key-press ch c-x-pressed?))
|
|
(obtain-lock paint-lock)
|
|
|
|
;;; only necessary when continueing a background job in fg
|
|
(if (redisplay-everything?)
|
|
(begin
|
|
(paint-result-frame-window)
|
|
(paint-active-command-window)
|
|
(unset-redisplay-everything)))
|
|
|
|
(paint-result-window (entry-data (current-history-item)))
|
|
(move-cursor (command-buffer) (result-buffer))
|
|
(refresh-result-window)
|
|
(release-lock paint-lock))
|
|
(loop (wait-for-input) #f))
|
|
(else
|
|
(input (command-buffer) ch)
|
|
(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)
|
|
(release-lock paint-lock)
|
|
(loop (wait-for-input) c-x-pressed?)))))))
|
|
|
|
(define (paint-bar-1)
|
|
(mvwaddstr (app-window-curses-win (bar-1)) 0 1 "Commander S")
|
|
(wrefresh (app-window-curses-win (bar-1))))
|
|
|
|
(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))
|
|
0
|
|
(- (- (app-window-width (command-frame-window))
|
|
(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))
|
|
(paint-command-buffer-mode-indicator)
|
|
(paint-job-status-list)
|
|
(wrefresh (app-window-curses-win (command-frame-window))))
|
|
|
|
(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)))
|
|
((stopped) (stat-item "stop:" (cdr status.count)))
|
|
((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))
|
|
(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)))
|
|
|
|
(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))))
|
|
(werase win)
|
|
(box win (ascii->char 0) (ascii->char 0))
|
|
(wrefresh win)))
|
|
|
|
(define (paint-result-window entry)
|
|
(let ((win (app-window-curses-win (result-window))))
|
|
(werase 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))))
|
|
|
|
(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)
|
|
((view-plugin-constructor view-plugin)
|
|
result (result-buffer))))
|
|
(else
|
|
(make-standard-viewer result (result-buffer)))))
|
|
|
|
;;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))
|
|
|
|
|
|
(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
|
|
(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))))
|
|
|
|
;;add a string to the buffer
|
|
(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
|
|
(if (history-entry-command (entry-data entry))
|
|
(history-entry-command (entry-data entry))
|
|
"user interaction")
|
|
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))))))
|
|
|
|
;;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)))
|
|
|
|
(define (sublist l pos k)
|
|
(let ((tmp (list-tail l pos)))
|
|
(reverse (list-tail (reverse tmp)
|
|
(- (length tmp) k)))))
|
|
|
|
;;When NUIT is closed the state has to be restored, in order to let the
|
|
;;user start again from scratch
|
|
(define (restore-state)
|
|
(set! history '())
|
|
(set! history-pos 0)
|
|
(set! active-keyboard-interrupt #f))
|
|
|
|
(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))))))
|
|
|
|
(define (completions->select-list completions num-lines)
|
|
(debug-message "possible completions " completions)
|
|
(make-select-list
|
|
(map (lambda (s) (make-unmarked-text-element s #f s))
|
|
completions)
|
|
num-lines))
|
|
|
|
(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 (current-cursor-index)
|
|
;; #### No, I will not comment on this.
|
|
(- (buffer-pos-col (command-buffer)) 2))
|
|
|
|
(define (offer-completions command)
|
|
(debug-message "offer-completions '" command "' " (current-cursor-index))
|
|
(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
|
|
(((maybe-completed-line completions cursor-index to-complete cmdln) completion-info))
|
|
|
|
(if maybe-completed-line
|
|
;; #### don't ask about the 2...
|
|
(display-completed-line maybe-completed-line (+ 2 cursor-index)))
|
|
|
|
(cond
|
|
((null? completions)
|
|
#f)
|
|
((list? completions)
|
|
(set-modal-window!
|
|
(make-completions-window command completions cmdln to-complete)))
|
|
(else
|
|
(error "COMPLETE returned an unexpected value"
|
|
completions)))))))
|
|
|
|
(define (make-completions-window command completions
|
|
cmdln to-complete)
|
|
(define header-line "Select completion")
|
|
(define header-length (string-length header-line))
|
|
|
|
(let* ((lines 10)
|
|
(inner-width
|
|
(min (apply max header-length
|
|
(map string-length completions))
|
|
(COLS)))
|
|
(dialog (make-app-window (- (quotient (COLS) 2)
|
|
(quotient inner-width 2))
|
|
5
|
|
(+ 4 inner-width)
|
|
lines)))
|
|
(app-window-init-curses-win! dialog)
|
|
(let* ((dialog-win (app-window-curses-win dialog))
|
|
(select-list
|
|
(completions->select-list
|
|
completions
|
|
(- lines 3))))
|
|
|
|
(define (paint)
|
|
(werase dialog-win)
|
|
(box dialog-win
|
|
(ascii->char 0) (ascii->char 0))
|
|
(mvwaddstr dialog-win
|
|
0
|
|
(+ 1 (quotient (- inner-width header-length) 2))
|
|
header-line)
|
|
(paint-selection-list-at select-list 1 1
|
|
dialog-win inner-width #t)
|
|
(wrefresh dialog-win))
|
|
(paint)
|
|
(lambda (key)
|
|
(cond
|
|
((= key 27)
|
|
(delete-app-window! dialog)
|
|
(close-modal-window!)
|
|
#t)
|
|
((= key 10)
|
|
(let ((completion
|
|
(select-list-selected-entry select-list)))
|
|
;; #### No, I will not comment on this.
|
|
(call-with-values
|
|
(lambda ()
|
|
(unparse-command-line cmdln
|
|
(lambda (to-complete)
|
|
(display completion))))
|
|
(lambda (completed-line new-cursor-pos)
|
|
(display-completed-line completed-line
|
|
(+ 2 new-cursor-pos))))
|
|
(delete-app-window! dialog)
|
|
#t))
|
|
((select-list-key? key)
|
|
(set! select-list
|
|
(select-list-handle-key-press select-list key))
|
|
(paint)
|
|
#f)
|
|
(else
|
|
#f))))))
|
|
|