(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?)) ;;; viewer for a single job viewer (define (make-job-viewer job buffer) (let ((select-list #f) (num-cols (- (result-buffer-num-cols buffer) 1))) (define (make-job-select-list job) (make-select-list (map (lambda (args) (make-unmarked-element (car args) #f (cut-to-size num-cols (apply string-append (append (list (fill-up-string 15 (cadr args))) (cddr args)))))) (list (list (job-name->string (job-name job)) "name:" (job-name->string (job-name job))) (list (if (job-end-time job) (number->string (job-status job)) #f) "status:" (if (job-end-time job) (number->string (job-status job)) "-")) (list (job-start-time job) "start:" (short-date (job-start-time job))) (list (job-end-time job) "end:" (if (job-end-time job) (short-date (job-end-time job)) "-")) (list #f "run status:" (symbol->string (job-run-status job))) (list (job-console job) "" ""))) (- (result-buffer-num-lines buffer) 1))) (define (handle-key-press self key control-x-pressed?) (cond ((= key (char->ascii #\g)) (set! select-list (make-job-select-list job))) ((= key (char->ascii #\newline)) (select-list-selected-entry select-list)) (else (set! select-list (select-list-handle-key-press select-list key)))) self) (set! select-list (make-job-select-list job)) (lambda (message) (case message ((paint) (lambda (self win buffer have-focus?) (mvwaddstr win 0 0 (cut-to-size num-cols (string-append "Viewing job: " (job-name->string (job-name job))))) (paint-selection-list-at select-list 0 1 win buffer have-focus?))) ((key-press) handle-key-press) ((get-selection) (make-get-focus-object-method select-list)) ((get-focus-object) (make-get-focus-object-method select-list)) (else (error "job viewer unknown message" message)))))) (register-plugin! (make-view-plugin make-job-viewer job?))