108 lines
2.7 KiB
Scheme
108 lines
2.7 KiB
Scheme
|
(define (job-name->string name)
|
||
|
|
(let ((port (open-output-string)))
|
||
|
|
(display name port)
|
||
|
|
(get-output-string port)))
|
||
|
|
|
||
|
|
(define (short-date date)
|
||
|
|
(fill-up-string 10
|
||
|
|
(format-date "~H:~M:~S" date)))
|
||
|
|
|
||
|
|
(define (format-job-run-state job)
|
||
|
|
(fill-up-string 12
|
||
|
|
(cond
|
||
|
|
((job-running? job) "running")
|
||
|
|
((job-ready? job) "ready")
|
||
|
|
((job-waiting-for-input? job) "stop/input")
|
||
|
|
((and (job-end-time job)
|
||
|
|
(job-has-new-output? job) "ready/output"))
|
||
|
|
(else "run/output"))))
|
||
|
|
|
||
|
|
(define (format-job job num-cols)
|
||
|
|
(cut-to-size num-cols
|
||
|
|
(string-append
|
||
|
|
(fill-up-string
|
||
|
|
20 (job-name->string (job-name job)))
|
||
|
|
" "
|
||
|
|
(format-job-run-state job)
|
||
|
|
" "
|
||
|
|
(short-date (job-start-time job))
|
||
|
|
" "
|
||
|
|
(if (job-end-time job)
|
||
|
|
(short-date (job-end-time job))
|
||
|
|
(fill-up-string 12 "-"))
|
||
|
|
" "
|
||
|
|
(fill-up-string
|
||
|
|
6 (if (job-end-time job)
|
||
|
|
(number->string (job-status job))
|
||
|
|
"-")))))
|
||
|
|
|
||
|
|
(define (make-joblist-headline num-cols)
|
||
|
|
(cut-to-size
|
||
|
|
num-cols
|
||
|
|
(string-append
|
||
|
|
(fill-up-string 20 "NAME")
|
||
|
|
" "
|
||
|
|
(fill-up-string 12 "RUN STATUS")
|
||
|
|
" "
|
||
|
|
(fill-up-string 10 "START")
|
||
|
|
" "
|
||
|
|
(fill-up-string 10 "END")
|
||
|
|
" "
|
||
|
|
(fill-up-string 6 "STATUS"))))
|
||
|
|
|
||
|
|
(define (make-joblist-viewer jobs buffer)
|
||
|
|
(let* ((jobs jobs)
|
||
|
|
(num-cols (- (result-buffer-num-cols buffer) 1))
|
||
|
|
(headline (make-joblist-headline num-cols))
|
||
|
|
(select-list
|
||
|
|
(make-select-list
|
||
|
|
(map (lambda (job)
|
||
|
|
(make-unmarked-element
|
||
|
|
job #t (format-job job num-cols)))
|
||
|
|
jobs)
|
||
|
|
(- (result-buffer-num-lines buffer) 1))))
|
||
|
|
|
||
|
|
(define get-focus-object
|
||
|
|
(make-get-focus-object-method select-list))
|
||
|
|
|
||
|
|
(define (get-selection self for-scheme-mode? focus-object-table)
|
||
|
|
(if for-scheme-mode?
|
||
|
|
(send self 'get-focus-object focus-object-table)
|
||
|
|
(let ((marked (select-list-get-selection select-list)))
|
||
|
|
(if (null? marked)
|
||
|
|
(number->string
|
||
|
|
(proc:pid (job-proc (select-list-selected-entry select-list))))
|
||
|
|
(string-join (map (lambda (job)
|
||
|
|
(number->string
|
||
|
|
(proc:pid (job-proc job))))
|
||
|
|
marked))))))
|
||
|
|
|
||
|
|
(lambda (message)
|
||
|
|
|
||
|
|
(case message
|
||
|
|
|
||
|
|
((paint)
|
||
|
|
(lambda (self win buffer have-focus?)
|
||
|
|
(mvwaddstr win 0 0 headline)
|
||
|
|
(paint-selection-list-at
|
||
|
|
select-list 0 1 win buffer have-focus?)))
|
||
|
|
|
||
|
|
((key-press)
|
||
|
|
(lambda (self key control-x-pressed?)
|
||
|
|
(set! select-list
|
||
|
|
(select-list-handle-key-press select-list key))
|
||
|
|
self))
|
||
|
|
|
||
|
|
((get-selection) get-selection)
|
||
|
|
|
||
|
|
((get-focus-object) get-focus-object)
|
||
|
|
|
||
|
|
(else
|
||
|
|
(error "joblist-viewer unknown message" message))))))
|
||
|
|
|
||
|
|
(define (list-of-jobs? thing)
|
||
|
|
(and (proper-list? thing) (every job? thing)))
|
||
|
|
|
||
|
|
(register-plugin!
|
||
|
|
(make-view-plugin make-joblist-viewer list-of-jobs?))
|