diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index defc4db..d54a797 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -349,6 +349,7 @@ select-element (subset focus-table (make-focus-object-reference)) + layout tty-debug utils ncurses) diff --git a/scheme/process.scm b/scheme/process.scm index 831b1c0..87ff0a1 100644 --- a/scheme/process.scm +++ b/scheme/process.scm @@ -2,15 +2,14 @@ (and (proper-list? thing) (every process-info? thing))) -(define (make-header-line width) +(define (make-header-line) (make-select-line (list - (right-align-string 6 "PID ") - (right-align-string 6 "PPID ") - (left-align-string 9 "USER ") - (right-align-string 6 "TIME ") - "COMMAND") - width)) + (make-unmarked-text-element 'pid #f (right-align-string 6 "PID ")) + (make-unmarked-text-element 'ppid #f (right-align-string 6 "PPID ")) + (make-unmarked-text-element 'user #f (left-align-string 9 "USER ")) + (make-unmarked-text-element 'time #f (right-align-string 6 "TIME ")) + (make-unmarked-text-element 'command #f "COMMAND")))) (define (layout-process width p) (cut-to-size @@ -40,34 +39,20 @@ processes) num-lines))) -(define-option 'ps 'sort-user-up-key (char->ascii #\u)) -(define-option 'ps 'sort-user-down-key (char->ascii #\U)) -(define-option 'ps 'sort-pid-up-key (char->ascii #\p)) -(define-option 'ps 'sort-pid-down-key (char->ascii #\P)) -(define-option 'ps 'sort-time-up-key (char->ascii #\t)) -(define-option 'ps 'sort-time-down-key (char->ascii #\T)) (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 (make-pps-viewer processes buffer) (let* ((processes processes) - (header-line (make-header-line (result-buffer-num-cols buffer))) + (header-line (make-header-line)) (select-list (make-process-selection-list (result-buffer-num-cols buffer) (result-buffer-num-lines buffer) processes))) - (define sorting-keys - (map - (cut config 'ps <>) - (list 'sort-time-up-key - 'sort-time-down-key - 'sort-user-up-key - 'sort-user-down-key - 'sort-pid-up-key - 'sort-pid-down-key))) - (define (set-processes! new-processes) (set! processes new-processes) (set! select-list @@ -94,62 +79,64 @@ (lambda (message) (case message - ((paint) - (lambda (self win buffer have-focus?) - (paint-select-line-at header-line 0 0 win) - (paint-selection-list-at - select-list 0 1 win buffer have-focus?))) + ((paint) + (lambda (self win buffer have-focus?) + (paint-select-line-at header-line 0 0 win buffer) + (paint-selection-list-at + select-list 0 1 win buffer have-focus?))) - ((key-press) - (lambda (self key control-x-pressed?) - (cond - ((member key sorting-keys) - (receive (compare select) - (cond - ((= key (config 'ps 'sort-time-up-key)) - (values < process-info-time)) - ((= key (config 'ps 'sort-time-down-key)) - (values > process-info-time)) - ((= key (config 'ps 'sort-user-up-key)) - (values string? process-info-logname)) - ((= key (config 'ps 'sort-pid-up-key)) - (values < process-info-pid)) - ((= key (config 'ps 'sort-pid-down-key)) - (values > process-info-pid))) - (set-processes! - (list-sort - (lambda (p1 p2) - (compare (select p1) (select p2))) - processes)) - self)) - ((= key (config 'ps 'kill-key)) - (let ((infos - (select-list-get-selection select-list))) - (for-each - (cut signal-process <> signal/term) - (map process-info-pid infos))) - self) - ((= key (config 'ps 'refresh-key)) - (set-processes! (pps)) - self) - ((select-list-key? key) - (set! select-list - (select-list-handle-key-press select-list key)) - self) - ((select-line-key? key) - (select-line-handle-key-press! header-line key) - self) - (else self)))) + ((key-press) + (lambda (self key control-x-pressed?) + (cond + ((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))) + (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)) + self)))) + ((= key (config 'ps 'kill-key)) + (let ((infos + (select-list-get-selection select-list))) + (for-each + (cut signal-process <> signal/term) + (map process-info-pid infos))) + self) + ((= key (config 'ps 'refresh-key)) + (set-processes! (pps)) + self) + ((select-list-key? key) + (set! select-list + (select-list-handle-key-press select-list key)) + self) + ((select-line-key? key) + (select-line-handle-key-press! header-line key) + self) + (else self)))) - ((get-selection-as-text) get-selection-as-text) + ((get-selection-as-text) get-selection-as-text) - ((get-selection-as-ref) - (make-get-selection-as-ref-method select-list)) + ((get-selection-as-ref) + (make-get-selection-as-ref-method select-list)) - (else - (error "pps-viewer unknown message" message)))))) + (else + (error "pps-viewer unknown message" message)))))) (register-plugin! (make-view-plugin make-pps-viewer list-of-processes?)) diff --git a/scheme/select-line.scm b/scheme/select-line.scm index 45b3160..bd62dc1 100644 --- a/scheme/select-line.scm +++ b/scheme/select-line.scm @@ -1,34 +1,12 @@ -;(define-record-type element -; (make-element markable? marked? value text) -; element? -; (markable? element-markable?) -; (marked? element-marked?) -; (value element-value) -; (text element-text)) - -;(define-record-discloser :element -; (lambda (r) -; `(element ,(element-marked? r) ,(element-text r)))) - -;(define (make-unmarked-element value markable? text) -; (make-element markable? #f value text)) - -;(define (make-marked-element value markable? text) -; (make-element markable? #t value text)) - -(define (element-value x) x) -(define (element-text x) x) - (define-record-type select-line :select-line - (really-make-select-line elements cursor-index num-cols width) + (really-make-select-line elements cursor-index num-cols) select-line? (elements select-line-elements) (cursor-index select-line-cursor-index set-select-line-cursor-index!) - (num-cols select-line-num-cols) - (width select-line-width)) + (num-cols select-line-num-cols)) -(define (make-select-line elements width) - (really-make-select-line elements 0 (length elements) width)) +(define (make-select-line elements) + (really-make-select-line elements 0 (length elements))) (define (select-line-key? key) (or (= key key-right) @@ -53,30 +31,23 @@ (if (< old-col (- (select-line-num-cols select-line) 1)) (set-select-line-cursor-index! select-line (+ old-col 1))))) -(define (paint-select-line select-line win) - (paint-select-line-at select-line 0 0 win)) +(define (paint-select-line select-line win result-buffer) + (paint-select-line-at select-line 0 0 win result-buffer)) -(define (paint-select-line-at select-line x y win) - (let ((cursor-col (select-line-cursor-index select-line))) +(define (paint-select-line-at select-line x y win result-buffer) + (let ((cursor-col (select-line-cursor-index select-line)) + (width (result-buffer-num-cols result-buffer))) (let lp ((elts (select-line-elements select-line)) (i 0) (x x)) (cond ((null? elts) (values)) ((= i cursor-col) - (let ((text (cut-to-size (- (select-line-width select-line) - x) - (element-text (car elts))))) - (wattron win (A-REVERSE)) - (mvwaddstr win y x text) - (wattrset win (A-NORMAL)) - (lp (cdr elts) (+ i 1) (+ x (string-length text))))) + (let ((new-x ((element-painter (car elts)) win x y width #t #f))) ; no marking for now + (lp (cdr elts) (+ i 1) new-x))) (else - (let ((text (cut-to-size (- (select-line-width select-line) - x) - (element-text (car elts))))) - (mvwaddstr win y x text) - (lp (cdr elts) (+ i 1) (+ x (string-length text))))))))) + (let ((new-x ((element-painter (car elts)) win x y width #f #f))) + (lp (cdr elts) (+ i 1) new-x))))))) (define (select-line-selected-entry select-line) (element-value diff --git a/scheme/select-list.scm b/scheme/select-list.scm index 914b5f2..e43c6cf 100644 --- a/scheme/select-list.scm +++ b/scheme/select-list.scm @@ -128,9 +128,11 @@ (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 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)) - (cursor-index (select-list-cursor-index select-list))) + (cursor-index (select-list-cursor-index select-list)) + (width (result-buffer-num-cols result-buffer))) (let lp ((elts (select-visible-elements select-list num-lines)) (y y) @@ -139,13 +141,13 @@ ((null? elts) (values)) ((= i cursor-index) - ((element-painter (car elts)) win x y #t (element-marked? (car elts))) - (lp (cdr elts) (+ y 1) (+ i 1))) + ((element-painter (car elts)) win x y width #t (element-marked? (car elts))) + (lp (cdr elts) (+ y 1) (+ i 1))) ((element-marked? (car elts)) - ((element-painter (car elts)) win x y #f #t) - (lp (cdr elts) (+ y 1) (+ i 1))) + ((element-painter (car elts)) win x y width #f #t) + (lp (cdr elts) (+ y 1) (+ i 1))) (else - ((element-painter (car elts)) win x y #f #f) + ((element-painter (car elts)) win x y width #f #f) (lp (cdr elts) (+ y 1) (+ i 1))))))) (define (select-list-get-marked select-list)