diff --git a/scheme/process.scm b/scheme/process.scm index b9b837f..6b4857b 100644 --- a/scheme/process.scm +++ b/scheme/process.scm @@ -11,6 +11,19 @@ (make-unmarked-text-element 'time #f (right-align-string 6 "TIME ")) (make-unmarked-text-element 'command #f "COMMAND")))) + +(define (column->opertions column) + (case column + ((pid) (values < = > process-info-pid)) + ((ppid) (values < = > process-info-ppid)) + ((user) (values string? + process-info-logname)) + ((time) (values < = > process-info-time)) + ((command) (values string? + process-info-executable)) + (else + (error "unknown column" column)))) + (define (layout-process width p) (cut-to-size width @@ -39,10 +52,61 @@ processes) num-lines))) +(define (make-filter-window list-viewer entries + compare-val select-val) + (let* ((vals + (delete-duplicates + (map select-val entries) compare-val)) + (val-strings + (map display-to-string vals)) + (max-width + (apply max (map string-length val-strings))) + (dialog (make-app-window 10 10 (+ 2 max-width) 10))) + (app-window-init-curses-win! dialog) + (let* ((dialog-win (app-window-curses-win dialog)) + (select-list + (make-select-list + (map (lambda (val str) + (make-unmarked-text-element + val #f str)) + vals val-strings) + 7))) + + (define (paint) + (werase dialog-win) + (box dialog-win + (ascii->char 0) (ascii->char 0)) + (paint-selection-list-at select-list 1 1 dialog-win max-width #t) + (wrefresh dialog-win)) + + (paint) + (lambda (key) + (cond ((= key 27) + (delete-app-window! dialog) + (close-modal-window!) + #t) + ((select-list-key? key) + (set! select-list + (select-list-handle-key-press select-list key)) + (paint) + #f) + ((= key 10) + (let* ((val (select-list-selected-entry select-list)) + (new-entries + (filter (lambda (entry) + (compare-val (select-val entry) + val)) entries))) + (send list-viewer 'set-entries! new-entries)) + (delete-app-window! dialog) + (close-modal-window!) + #t) + (else #f)))))) + (define-option 'ps 'kill-key (char->ascii #\k)) (define-option 'ps 'refresh-key (char->ascii #\g)) (define-option 'ps 'sort-up-key (char->ascii #\s)) (define-option 'ps 'sort-down-key (char->ascii #\S)) +(define-option 'ps 'filter-key (char->ascii #\f)) (define (make-pps-viewer processes buffer) (let* ((processes processes) @@ -84,26 +148,24 @@ ((or (= key (config 'ps 'sort-up-key)) (= key (config 'ps 'sort-down-key))) (let ((column (select-line-selected-entry header-line))) - (receive (compare-up compare-down select) - (case column - ((pid) (values < > process-info-pid)) - ((ppid) (values < > process-info-ppid)) - ((user) (values string? - process-info-logname)) - ((time) (values < > process-info-time)) - ((command) (values string? - process-info-executable)) - (else - (error "unknown column" column))) + (receive (compare-up compare-equal compare-down select) + (column->opertions column) (let ((compare (if (= key (config 'ps 'sort-up-key)) compare-up compare-down))) - (set-processes! - (list-sort - (lambda (p1 p2) - (compare (select p1) (select p2))) - processes)) + (send self 'set-processes! + (list-sort + (lambda (p1 p2) + (compare (select p1) (select p2))) + processes)) self)))) + ((= key (config 'ps 'filter-key)) + (receive (compare-up compare-equal compare-down select) + (column->opertions + (select-line-selected-entry header-line)) + (set-modal-window! + (make-filter-window self processes compare-equal select)) + self)) ((= key (config 'ps 'kill-key)) (let ((infos (select-list-get-selection select-list))) @@ -112,7 +174,7 @@ (map process-info-pid infos))) self) ((= key (config 'ps 'refresh-key)) - (set-processes! (pps)) + (send self 'set-processes! (pps)) self) ((select-list-key? key) (set! select-list @@ -127,7 +189,19 @@ ((get-selection-as-ref) (make-get-selection-as-ref-method select-list)) - + + ((set-entries!) + (lambda (self processes) + (send self 'set-processes! processes))) + + ((set-processes!) + (lambda (self new-processes) + (set! processes new-processes) + (set! select-list + (make-process-selection-list + (result-buffer-num-cols buffer) + (- (result-buffer-num-lines buffer) 1) + new-processes)))) (else (error "pps-viewer unknown message" message)))))) diff --git a/scheme/select-element.scm b/scheme/select-element.scm new file mode 100644 index 0000000..30435f8 --- /dev/null +++ b/scheme/select-element.scm @@ -0,0 +1,35 @@ +(define-record-type element :element + (make-element markable? marked? value painter) + element? + (markable? element-markable?) + (marked? element-marked?) + (value element-value) + (painter element-painter)) + +(define-record-discloser :element + (lambda (r) + `(element ,(element-marked? r) ,(element-value r)))) + +(define (make-unmarked-element value markable? painter) + (make-element markable? #f value painter)) + +(define (make-marked-element value markable? painter) + (make-element markable? #t value painter)) + +(define (make-unmarked-text-element value markable? text) + (make-unmarked-element value markable? (make-text-painter text))) + +(define (make-marked-text-element value markable? text) + (make-marked-element value markable? (make-text-painter text))) + +(define (make-text-painter text) + (lambda (win x y width at-cursor? marked?) + (if at-cursor? + (wattron win (A-REVERSE))) + (if marked? + (wattron win (A-BOLD))) + (mvwaddstr win y x text) + (if (or at-cursor? marked?) + (wattrset win (A-NORMAL))) + (+ x (string-length text)))) +