use an object-oriented approach for the plugins. deleted a lot of
cruft. broke some plugins (such as browse-directory-list.scm)
This commit is contained in:
eknauel
parent
54230412f8
commit
345712d2da
|
|
@ -116,12 +116,11 @@
|
|||
*current-history-item*)
|
||||
|
||||
(define-record-type history-entry :history-entry
|
||||
(make-history-entry command args result plugin)
|
||||
(make-history-entry command args viewer)
|
||||
history-entry?
|
||||
(command history-entry-command)
|
||||
(args history-entry-args)
|
||||
(result history-entry-result set-history-entry-result!)
|
||||
(plugin history-entry-plugin))
|
||||
(viewer history-entry-viewer set-history-entry-viewer!))
|
||||
|
||||
(define (current-history-entry-selector-maker selector)
|
||||
(lambda ()
|
||||
|
|
@ -137,14 +136,14 @@
|
|||
(define active-command-arguments
|
||||
(current-history-entry-selector-maker history-entry-args))
|
||||
|
||||
(define current-result
|
||||
(current-history-entry-selector-maker history-entry-result))
|
||||
(define current-viewer
|
||||
(current-history-entry-selector-maker history-entry-viewer))
|
||||
|
||||
(define (update-current-result! new-value)
|
||||
(define (update-current-viewer! new-viewer)
|
||||
(cond
|
||||
((current-history-item)
|
||||
=> (lambda (entry)
|
||||
(set-history-entry-result! (entry-data entry) new-value)))
|
||||
(set-history-entry-viewer! (entry-data entry) new-viewer)))
|
||||
(else (values))))
|
||||
|
||||
(define (append-to-history! history-entry)
|
||||
|
|
@ -244,40 +243,35 @@
|
|||
(let* ((tokens (split-command-line command-line))
|
||||
(command (car tokens))
|
||||
(args (cdr tokens))
|
||||
(command-plugin (find-command-plugin command)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(find/init-plugin-for-result
|
||||
(with-errno-handler
|
||||
((errno data)
|
||||
(else data))
|
||||
((command-plugin-evaluater command-plugin) command args))))
|
||||
(lambda (result plugin)
|
||||
(let ((new-entry
|
||||
(make-history-entry command args
|
||||
result plugin)))
|
||||
;; FIXME, use insert here
|
||||
(append-to-history! new-entry)
|
||||
(buffer-text-append-new-line! command-buffer)
|
||||
(paint-result/command-buffer new-entry))))))
|
||||
(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)
|
||||
(buffer-text-append-new-line! command-buffer)
|
||||
(paint-result/command-buffer new-entry)))
|
||||
|
||||
(define (eval-command-in-scheme-mode command-line)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(find/init-plugin-for-result
|
||||
(eval-expression command-line)))
|
||||
(lambda (result plugin)
|
||||
(let* ((tokens (split-command-line command-line))
|
||||
(command (car tokens))
|
||||
(args (cdr tokens))
|
||||
(new-entry
|
||||
(make-history-entry command args
|
||||
result plugin)))
|
||||
;; FIXME, use insert here
|
||||
(append-to-history! new-entry)
|
||||
(buffer-text-append-new-line! command-buffer)
|
||||
(paint-result/command-buffer new-entry)))))
|
||||
(let ((viewer
|
||||
(find/init-plugin-for-result
|
||||
(eval-expression 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)
|
||||
(buffer-text-append-new-line! command-buffer)
|
||||
(paint-result/command-buffer new-entry))))
|
||||
|
||||
;; #### crufty
|
||||
(define split-command-line string-tokenize)
|
||||
|
||||
;; handle input
|
||||
|
|
@ -295,7 +289,6 @@
|
|||
(let loop ((ch (wait-for-input)) (c-x-pressed? #f)
|
||||
(completion-selector #f))
|
||||
|
||||
(debug-message "loop: " ch "|" c-x-pressed? "|" completion-selector)
|
||||
(cond
|
||||
|
||||
;; Ctrl-x -> wait for next input
|
||||
|
|
@ -341,22 +334,14 @@
|
|||
(current-history-item)
|
||||
(= ch 112))
|
||||
(add-string-to-command-buffer
|
||||
(post-message
|
||||
(history-entry-plugin (entry-data (current-history-item)))
|
||||
(make-selection-message (active-command) (current-result))))
|
||||
(send (current-viewer) 'get-selection))
|
||||
(loop (wait-for-input) #f #f))
|
||||
|
||||
((and c-x-pressed? (focus-on-result-buffer?))
|
||||
(let ((key-message
|
||||
(make-key-pressed-message
|
||||
(active-command) (current-result)
|
||||
result-buffer
|
||||
ch key-control-x)))
|
||||
(update-current-result!
|
||||
(post-message
|
||||
(history-entry-plugin (entry-data (current-history-item)))
|
||||
key-message))
|
||||
(loop (wait-for-input) #f #f)))
|
||||
(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?)
|
||||
|
|
@ -396,13 +381,9 @@
|
|||
(cond
|
||||
((focus-on-result-buffer?)
|
||||
(when (current-history-item)
|
||||
(update-current-result!
|
||||
(post-message
|
||||
(history-entry-plugin (entry-data (current-history-item)))
|
||||
(make-key-pressed-message
|
||||
(active-command) (current-result)
|
||||
result-buffer
|
||||
ch c-x-pressed?)))
|
||||
(update-current-viewer!
|
||||
(send (current-viewer)
|
||||
'key-press ch c-x-pressed?))
|
||||
(paint-result-window (entry-data (current-history-item)))
|
||||
(move-cursor command-buffer result-buffer)
|
||||
(refresh-result-window))
|
||||
|
|
@ -536,13 +517,10 @@
|
|||
(wrefresh win)))
|
||||
|
||||
(define (paint-result-window entry)
|
||||
(wclear (app-window-curses-win result-window))
|
||||
(paint-result-buffer
|
||||
(post-message
|
||||
(history-entry-plugin entry)
|
||||
(make-print-message (history-entry-command entry)
|
||||
(history-entry-result entry)
|
||||
(buffer-num-cols command-buffer)))))
|
||||
(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)))
|
||||
|
|
@ -578,75 +556,12 @@
|
|||
(define (find/init-plugin-for-result result)
|
||||
(cond
|
||||
((determine-plugin-by-type result)
|
||||
=> (lambda (plugin)
|
||||
(values
|
||||
(post-message plugin
|
||||
(make-init-with-result-message
|
||||
result result-buffer))
|
||||
plugin)))
|
||||
=> (lambda (view-plugin)
|
||||
(let ((instance ((view-plugin-constructor view-plugin))))
|
||||
(send instance 'init result result-buffer))))
|
||||
(else
|
||||
(values
|
||||
(post-message standard-view-plugin
|
||||
(make-init-with-result-message
|
||||
result result-buffer))
|
||||
standard-view-plugin))))
|
||||
|
||||
;;Extracts the name of the function and its parameters
|
||||
(define extract-com-and-par
|
||||
(lambda (com)
|
||||
(if (<= (string-length com) 0)
|
||||
(cons "" '())
|
||||
(if (equal? #\( (string-ref com 0))
|
||||
(cons com '())
|
||||
(let* ((fst-word (get-next-word com))
|
||||
(command (car fst-word))
|
||||
(rest (cdr fst-word)))
|
||||
(let loop ((param-str rest)
|
||||
(param-list '()))
|
||||
(let* ((word (get-next-word param-str))
|
||||
(param (car word))
|
||||
(more (cdr word)))
|
||||
(if (equal? "" param)
|
||||
(cons command param-list)
|
||||
(loop more (append param-list (list param)))))))))))
|
||||
|
||||
;;gets the next word from a string
|
||||
(define (get-next-word str)
|
||||
(let loop ((old str)
|
||||
(new ""))
|
||||
(if (= 0 (string-length old))
|
||||
(cons new old)
|
||||
(if (char=? #\space (string-ref old 0))
|
||||
(if (= 1 (string-length old))
|
||||
(cons new "")
|
||||
(cons new (substring old 1 (string-length old))))
|
||||
(if (char=? #\( (string-ref old 0))
|
||||
(let* ((nw (get-next-word-braces
|
||||
(substring old 1
|
||||
(string-length old))))
|
||||
(nw-new (car nw))
|
||||
(nw-old (cdr nw)))
|
||||
(loop nw-old (string-append new "(" nw-new)))
|
||||
(loop (substring old 1 (string-length old))
|
||||
(string-append new (string (string-ref old 0)))))))))
|
||||
|
||||
(define (get-next-word-braces str)
|
||||
(let loop ((old str)
|
||||
(new ""))
|
||||
(if (= 0 (string-length old))
|
||||
(cons new old)
|
||||
(if (char=? #\( (string-ref old 0))
|
||||
(let* ((nw (get-next-word-braces
|
||||
(substring old 1
|
||||
(string-length old))))
|
||||
(nw-new (car nw))
|
||||
(nw-old (cdr nw)))
|
||||
(loop nw-old (string-append new "(" nw-new)))
|
||||
(if (char=? #\) (string-ref old 0))
|
||||
(cons (string-append new ")")
|
||||
(substring old 1 (string-length old)))
|
||||
(loop (substring old 1 (string-length old))
|
||||
(string-append new (string (string-ref old 0)))))))))
|
||||
(let ((instance (make-standard-viewer)))
|
||||
(send instance 'init result result-buffer)))))
|
||||
|
||||
;;scroll buffer after one command was entered
|
||||
(define (scroll-command-buffer)
|
||||
|
|
@ -672,14 +587,6 @@
|
|||
(lambda ()
|
||||
(eval (read-sexp-from-string exp) env))))))
|
||||
|
||||
(define (post-message plugin message)
|
||||
(cond
|
||||
((view-plugin? plugin)
|
||||
((view-plugin-fun plugin) message))
|
||||
(else
|
||||
(error "don't know how to talk to this plugin type"
|
||||
plugin))))
|
||||
|
||||
(define (determine-plugin-by-type result)
|
||||
(find (lambda (r)
|
||||
((view-plugin-type-predicate r) result))
|
||||
|
|
@ -734,13 +641,6 @@
|
|||
(history-entry-command (entry-data entry)) width)))))
|
||||
(wrefresh win)))
|
||||
|
||||
(define (paint-result-buffer paint-proc)
|
||||
(debug-message "paint-result-buffer before")
|
||||
(paint-proc (app-window-curses-win result-window)
|
||||
result-buffer
|
||||
(focus-on-result-buffer?))
|
||||
(debug-message "paint-result-buffer after"))
|
||||
|
||||
;;Cursor
|
||||
;;move cursor to the corrct position
|
||||
(define (move-cursor command-buffer result-buffer)
|
||||
|
|
@ -890,7 +790,8 @@
|
|||
(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))
|
||||
((paint-selection-list-at select-list 0 2)
|
||||
win result-buffer (focus-on-result-buffer?))
|
||||
(refresh-result-window)))
|
||||
|
||||
;; #### implement me
|
||||
|
|
@ -960,11 +861,7 @@
|
|||
((or (select-list-navigation-key? key)
|
||||
(select-list-marking-key? key))
|
||||
(let ((new-select-list
|
||||
(select-list-handle-key-press
|
||||
select-list
|
||||
(make-key-pressed-message
|
||||
(active-command) (current-result)
|
||||
result-buffer key #f))))
|
||||
(select-list-handle-key-press select-list key)))
|
||||
(paint-completion-select-list
|
||||
new-select-list (last (buffer-text command-buffer)))
|
||||
(make-completion-selector
|
||||
|
|
@ -1016,56 +913,34 @@
|
|||
(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
|
||||
cursor-pos-x
|
||||
result-text
|
||||
result)
|
||||
standard-result-obj?
|
||||
(cursor-pos-y standard-result-obj-cur-pos-y)
|
||||
(cursor-pos-x standard-result-obj-cur-pos-x)
|
||||
(result-text standard-result-obj-result-text)
|
||||
(result standard-result-obj-result))
|
||||
(define (make-standard-viewer)
|
||||
(let ((x 1)
|
||||
(y 1)
|
||||
(text "")
|
||||
(value #f))
|
||||
|
||||
(define init-std-res
|
||||
(make-standard-result-obj 1 1 '("") ""))
|
||||
(lambda (message)
|
||||
(cond
|
||||
|
||||
;;Standard-Receiver:
|
||||
(define (standard-receiver-rec message)
|
||||
(cond
|
||||
((init-with-result-message? message)
|
||||
(make-standard-result-obj
|
||||
1 1
|
||||
(layout-result-standard
|
||||
(exp->string (init-with-result-message-result message))
|
||||
(result-buffer-num-cols
|
||||
(init-with-result-message-buffer message)))
|
||||
(init-with-result-message-result message)))
|
||||
((next-command-message? message)
|
||||
(let* ((result (eval-expression (message-command-string message)))
|
||||
(result-string (exp->string result))
|
||||
(width (next-command-message-width message))
|
||||
(text (layout-result-standard result-string width))
|
||||
(std-obj (make-standard-result-obj 1 1 text result)))
|
||||
std-obj))
|
||||
((print-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(pos-y (standard-result-obj-cur-pos-y model))
|
||||
(pos-x (standard-result-obj-cur-pos-x model))
|
||||
(width (print-message-width message))
|
||||
(result (standard-result-obj-result model))
|
||||
(text (layout-result-standard
|
||||
(exp->string result) width)))
|
||||
(make-simple-result-buffer-printer
|
||||
pos-y pos-x text '() '())))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(message-result-object message))
|
||||
((restore-message? message)
|
||||
(values))
|
||||
((selection-message? message)
|
||||
"")))
|
||||
((eq? message 'init)
|
||||
(lambda (self new-value buffer)
|
||||
(set! value new-value)
|
||||
(set! text
|
||||
(layout-result-standard
|
||||
(exp->string value)
|
||||
(result-buffer-num-cols buffer)))
|
||||
self))
|
||||
|
||||
((eq? message 'paint)
|
||||
(lambda (self win buffer have-focus?)
|
||||
;; #### get rid of this cruft
|
||||
((make-simple-result-buffer-printer y x text '() '())
|
||||
win buffer have-focus?)))
|
||||
|
||||
((eq? message 'key)
|
||||
(lambda (self . ignore)
|
||||
self))))))
|
||||
|
||||
(define standard-view-plugin
|
||||
(make-view-plugin standard-receiver-rec
|
||||
(make-view-plugin make-standard-viewer
|
||||
(lambda (val) #t)))
|
||||
|
|
|
|||
|
|
@ -70,13 +70,14 @@
|
|||
|
||||
;;; process viewer plugin
|
||||
|
||||
(define-structure process-view-plugin
|
||||
(define-structure process-viewer
|
||||
(export)
|
||||
(open scheme
|
||||
define-record-types
|
||||
srfi-1
|
||||
srfi-13
|
||||
formats
|
||||
signals
|
||||
|
||||
pps
|
||||
plugin
|
||||
|
|
@ -214,7 +215,7 @@
|
|||
(define-interface plugin-interface
|
||||
(export make-view-plugin
|
||||
view-plugin?
|
||||
view-plugin-fun
|
||||
view-plugin-constructor
|
||||
view-plugin-type-predicate
|
||||
|
||||
make-command-plugin
|
||||
|
|
@ -223,49 +224,12 @@
|
|||
command-plugin-completer
|
||||
command-plugin-evaluater
|
||||
|
||||
register-plugin!
|
||||
|
||||
next-command-message?
|
||||
next-command-string
|
||||
next-command-message-parameters
|
||||
next-command-message-width
|
||||
|
||||
init-with-result-message?
|
||||
init-with-result-message-result
|
||||
init-with-result-message-buffer
|
||||
|
||||
key-pressed-message?
|
||||
key-pressed-message-result-buffer
|
||||
key-pressed-message-result-object
|
||||
key-pressed-message-key
|
||||
key-pressed-message-prefix-key
|
||||
|
||||
print-message?
|
||||
print-message-command-string
|
||||
print-message-result-object
|
||||
print-message-width
|
||||
|
||||
restore-message?
|
||||
restore-message-command-string
|
||||
restore-message-result-object
|
||||
|
||||
selection-message?
|
||||
selection-message-command-string
|
||||
selection-message-result-object
|
||||
|
||||
message-result-object
|
||||
message-command-string))
|
||||
register-plugin!))
|
||||
|
||||
(define-interface plugin-host-interface
|
||||
(export command-plugin-list
|
||||
view-plugin-list
|
||||
command-completions
|
||||
make-next-command-message
|
||||
make-init-with-result-message
|
||||
make-key-pressed-message
|
||||
make-print-message
|
||||
make-restore-message
|
||||
make-selection-message))
|
||||
command-completions))
|
||||
|
||||
(define-structures
|
||||
((plugin plugin-interface)
|
||||
|
|
@ -278,6 +242,16 @@
|
|||
completion-sets)
|
||||
(files plugins))
|
||||
|
||||
;;; objects
|
||||
|
||||
(define-interface objects-interface
|
||||
(export send))
|
||||
|
||||
(define-structure objects objects-interface
|
||||
(open scheme
|
||||
signals)
|
||||
(files objects))
|
||||
|
||||
;;; focus table
|
||||
|
||||
; (define-interface focus-table-interface
|
||||
|
|
@ -332,6 +306,7 @@
|
|||
rt-modules
|
||||
tty-debug
|
||||
fs-object
|
||||
objects
|
||||
plugin
|
||||
plugin-host
|
||||
layout
|
||||
|
|
@ -342,7 +317,7 @@
|
|||
select-list
|
||||
;; the following modules are plugins
|
||||
dirlist-view-plugin
|
||||
process-view-plugin
|
||||
process-viewer
|
||||
standard-command-plugin
|
||||
nuit-inspector-plugin)
|
||||
(files nuit-engine))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
(define (get-method object message)
|
||||
(object message))
|
||||
|
||||
(define method? procedure?)
|
||||
|
||||
(define (send object message . args)
|
||||
(let ((method (get-method object message)))
|
||||
(if (method? method)
|
||||
(apply method (cons object args))
|
||||
(error "No method" message))))
|
||||
|
||||
|
|
@ -15,9 +15,9 @@
|
|||
*command-completions*)
|
||||
|
||||
(define-record-type view-plugin :view-plugin
|
||||
(make-view-plugin fun type-predicate)
|
||||
(make-view-plugin constructor type-predicate)
|
||||
view-plugin?
|
||||
(fun view-plugin-fun)
|
||||
(constructor view-plugin-constructor)
|
||||
(type-predicate view-plugin-type-predicate))
|
||||
|
||||
(define-record-type command-plugin :command-plugin
|
||||
|
|
@ -38,91 +38,3 @@
|
|||
(set! *view-plugins* (cons plugin *view-plugins*)))
|
||||
(error "unknown plugin type" plugin)))
|
||||
|
||||
;; messages
|
||||
|
||||
(define-record-type next-command-message :next-command-message
|
||||
(make-next-command-message command-string
|
||||
parameters
|
||||
width)
|
||||
next-command-message?
|
||||
(command-string next-command-string)
|
||||
(parameters next-command-message-parameters)
|
||||
(width next-command-message-width))
|
||||
|
||||
(define-record-type init-with-result-message :init-with-result-message
|
||||
(make-init-with-result-message result buffer)
|
||||
init-with-result-message?
|
||||
(result init-with-result-message-result)
|
||||
(buffer init-with-result-message-buffer))
|
||||
|
||||
;;key pressed
|
||||
;;The object and the key are send to the user-code, who returns the
|
||||
;;changed object.
|
||||
(define-record-type key-pressed-message :key-pressed-message
|
||||
(make-key-pressed-message command-string
|
||||
result-object
|
||||
result-buffer
|
||||
key prefix-key)
|
||||
key-pressed-message?
|
||||
(command-string key-pressed-command-string)
|
||||
(result-object key-pressed-message-result-object)
|
||||
(result-buffer key-pressed-message-result-buffer)
|
||||
(key key-pressed-message-key)
|
||||
(prefix-key key-pressed-message-prefix-key))
|
||||
|
||||
;;print
|
||||
(define-record-type print-message :print-message
|
||||
(make-print-message command-string
|
||||
result-object
|
||||
width)
|
||||
print-message?
|
||||
(command-string print-message-command-string)
|
||||
(result-object print-message-result-object)
|
||||
(width print-message-width))
|
||||
|
||||
;;restore (when side-effects occur)
|
||||
(define-record-type restore-message :restore-message
|
||||
(make-restore-message command-string
|
||||
result-object)
|
||||
restore-message?
|
||||
(command-string restore-message-command-string)
|
||||
(result-object restore-message-result-object))
|
||||
|
||||
;;request the selection
|
||||
(define-record-type selection-message :selection-message
|
||||
(make-selection-message command-string
|
||||
result-object)
|
||||
selection-message?
|
||||
(command-string selection-message-command-string)
|
||||
(result-object selection-message-result-object))
|
||||
|
||||
(define (message-result-object message)
|
||||
((cond
|
||||
((key-pressed-message? message)
|
||||
key-pressed-message-result-object)
|
||||
((print-message? message)
|
||||
print-message-result-object)
|
||||
((restore-message? message)
|
||||
restore-message-result-object)
|
||||
((selection-message? message)
|
||||
selection-message-result-object)
|
||||
(else
|
||||
(error "This message-type has no field for result-objects"
|
||||
message)))
|
||||
message))
|
||||
|
||||
(define (message-command-string message)
|
||||
((cond
|
||||
((next-command-message? message)
|
||||
next-command-string)
|
||||
((key-pressed-message? message)
|
||||
key-pressed-command-string)
|
||||
((print-message? message)
|
||||
print-message-command-string)
|
||||
((restore-message? message)
|
||||
restore-message-command-string)
|
||||
((selection-message? message)
|
||||
selection-message-command-string)
|
||||
(else
|
||||
(error "This message-type has no command field" message)))
|
||||
message))
|
||||
|
|
|
|||
|
|
@ -1,14 +1,3 @@
|
|||
(define-record-type plugin-state :plugin-state
|
||||
(make-plugin-state processes selection-list cursor-x)
|
||||
plugin-state?
|
||||
(processes plugin-state-processes)
|
||||
(selection-list plugin-state-selection-list)
|
||||
(cursor-x plugin-state-cursor-x))
|
||||
|
||||
(define-record-discloser :plugin-state
|
||||
(lambda (r)
|
||||
`(plugin-state ,(plugin-state-selection-list r))))
|
||||
|
||||
(define (list-of-processes? thing)
|
||||
(and (proper-list? thing)
|
||||
(every process-info? thing)))
|
||||
|
|
@ -41,38 +30,35 @@
|
|||
processes)
|
||||
num-lines)))
|
||||
|
||||
(define (pps-receiver message)
|
||||
(debug-message "pps-receiver " message)
|
||||
(cond
|
||||
(define (make-pps-viewer)
|
||||
(let ((processes #f)
|
||||
(select-list #f))
|
||||
(lambda (message)
|
||||
(cond
|
||||
|
||||
((init-with-result-message? message)
|
||||
(let* ((processes (init-with-result-message-result message))
|
||||
(buffer (init-with-result-message-buffer message))
|
||||
(num-cols (result-buffer-num-cols buffer))
|
||||
(num-lines (result-buffer-num-lines buffer)))
|
||||
(make-plugin-state
|
||||
processes
|
||||
(make-process-selection-list num-cols num-lines processes) 1)))
|
||||
((eq? message 'init)
|
||||
(lambda (self process-list buffer)
|
||||
(let ((num-cols (result-buffer-num-cols buffer))
|
||||
(num-lines (result-buffer-num-lines buffer)))
|
||||
(set! processes process-list)
|
||||
(set! select-list
|
||||
(make-process-selection-list
|
||||
num-cols num-lines processes))
|
||||
self)))
|
||||
|
||||
((print-message? message)
|
||||
(paint-selection-list
|
||||
(plugin-state-selection-list
|
||||
(message-result-object message))))
|
||||
((eq? message 'paint)
|
||||
(lambda (self . args)
|
||||
(apply paint-selection-list
|
||||
(cons select-list args))))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(let ((old-state (message-result-object message)))
|
||||
(make-plugin-state
|
||||
(plugin-state-processes old-state)
|
||||
(select-list-handle-key-press
|
||||
(plugin-state-selection-list old-state)
|
||||
message)
|
||||
(plugin-state-cursor-x old-state))))
|
||||
|
||||
((restore-message? message)
|
||||
(values))
|
||||
|
||||
((selection-message? message)
|
||||
"'()")))
|
||||
((eq? message 'key-press)
|
||||
(lambda (self key control-x-pressed?)
|
||||
(set! select-list
|
||||
(select-list-handle-key-press select-list key))
|
||||
self))
|
||||
|
||||
(else
|
||||
(error "pps-viewer unknown message" message))))))
|
||||
|
||||
(register-plugin!
|
||||
(make-view-plugin pps-receiver list-of-processes?))
|
||||
(make-view-plugin make-pps-viewer list-of-processes?))
|
||||
|
|
|
|||
|
|
@ -37,21 +37,18 @@
|
|||
|
||||
(define key-u 117)
|
||||
|
||||
(define (select-list-handle-key-press select-list key-message)
|
||||
(let ((key (key-pressed-message-key key-message))
|
||||
(result-buffer (key-pressed-message-result-buffer key-message)))
|
||||
(debug-message "select-list-handle-key-press " select-list " " key)
|
||||
(cond
|
||||
((= key key-m)
|
||||
(mark-current-line select-list))
|
||||
((= key key-u)
|
||||
(unmark-current-line select-list))
|
||||
((= key key-up)
|
||||
(move-cursor-up select-list))
|
||||
((= key key-down)
|
||||
(move-cursor-down select-list))
|
||||
(else
|
||||
select-list))))
|
||||
(define (select-list-handle-key-press select-list key)
|
||||
(cond
|
||||
((= key key-m)
|
||||
(mark-current-line select-list))
|
||||
((= key key-u)
|
||||
(unmark-current-line select-list))
|
||||
((= key key-up)
|
||||
(move-cursor-up select-list))
|
||||
((= key key-down)
|
||||
(move-cursor-down select-list))
|
||||
(else
|
||||
select-list)))
|
||||
|
||||
(define (select-list-navigation-key? key)
|
||||
(or (= key key-up) (= key key-down)))
|
||||
|
|
@ -142,11 +139,10 @@
|
|||
(select-list-view-index select-list))
|
||||
(+ 1 num-lines)))
|
||||
|
||||
(define (paint-selection-list select-list)
|
||||
(paint-selection-list-at select-list 0 0))
|
||||
(define (paint-selection-list select-list win result-buffer have-focus?)
|
||||
(paint-selection-list-at select-list 0 0 win result-buffer have-focus?))
|
||||
|
||||
(define (paint-selection-list-at select-list x y)
|
||||
(lambda (win result-buffer have-focus?)
|
||||
(define (paint-selection-list-at select-list x y win result-buffer have-focus?)
|
||||
(let ((num-lines (select-list-num-lines select-list)))
|
||||
(let lp ((elts
|
||||
(select-visible-elements select-list num-lines))
|
||||
|
|
@ -167,7 +163,7 @@
|
|||
(lp (cdr elts) (+ y 1) (+ i 1)))
|
||||
(else
|
||||
(mvwaddstr win y x (element-text (car elts)))
|
||||
(lp (cdr elts) (+ y 1) (+ i 1))))))))
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))))))
|
||||
|
||||
(define (select-list-get-selection select-list)
|
||||
(map element-value
|
||||
|
|
|
|||
Loading…
Reference in New Issue