scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

New painting for select-line, new sorting for processes (by column) 

part of darcs patch Sun Sep 18 21:31:38 EEST 2005  Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
This commit is contained in:
eknauel 2005-09-27 16:30:57 +00:00
parent 4fbe6c5e51
commit 2b9854c8ff
4 changed files with 86 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scheme/nuit-packages.scm
View File

@ -349,6 +349,7 @@
select-element
(subset focus-table (make-focus-object-reference))
layout
tty-debug
utils
ncurses)

69
scheme/process.scm
View File

@ -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
@ -96,34 +81,36 @@
((paint)
(lambda (self win buffer have-focus?)
(paint-select-line-at header-line 0 0 win)
(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-user-down-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)))
((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<? string>?
process-info-logname))
((time) (values < > process-info-time))
((command) (values string<? 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))
self))))
((= key (config 'ps 'kill-key))
(let ((infos
(select-list-get-selection select-list)))

55
scheme/select-line.scm
View File

@ -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

12
scheme/select-list.scm
View File

@ -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)))
((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)
((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)