commander-s/scheme/job-viewer.scm

(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-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))))))
	`((,(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)
		`((,(job-console job) "<View Console>" ""))
		'())))
       (- (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))
       ((= 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?))