(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) "waiting for input") ((job-has-new-output? job) "waiting with output") ((job-stopped? job) "stopped") (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-selection-as-ref (make-get-selection-as-ref-method select-list)) (define (get-selection-as-text self for-scheme-mode? focus-object-table) (if for-scheme-mode? (send self 'get-selection-as-ref 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-as-text) get-selection-as-text) ((get-selection-as-ref) get-selection-as-ref) (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)) (console-viewer (if (job-with-console? job) (make-console-viewer (job-console job) buffer) #f))) (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)))))) `((,(job-name->string (job-name job)) "name:" ,(job-name->string (job-name job))) (,(if (job-end-time job) (number->string (job-status job)) #f) "status:" ,(if (job-end-time job) (number->string (job-status job)) "-")) (,(job-start-time job) "start:" ,(short-date (job-start-time job))) (,(job-end-time job) "end:" ,(if (job-end-time job) (short-date (job-end-time job)) "-")) (#f "run status:" ,(format-job-run-state job)) ,@(if (job-with-console? job) `((,console-viewer "" "")) '()))) (- (result-buffer-num-lines buffer) 1))) (define (handle-key-press self key control-x-pressed?) (cond ((= key (char->ascii #\f)) (continue-job-in-foreground job) self) ((= key (char->ascii #\g)) (set! select-list (make-job-select-list job)) self) ((= 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-as-text) (make-get-selection-as-ref-method select-list)) ((get-selection-as-ref) (make-get-selection-as-ref-method select-list)) (else (error "job viewer unknown message" message)))))) (register-plugin! (make-view-plugin make-job-viewer job?))