diff --git a/scheme/browse-directory-list.scm b/scheme/browse-directory-list.scm index 6f4c34d..63841ba 100644 --- a/scheme/browse-directory-list.scm +++ b/scheme/browse-directory-list.scm @@ -206,7 +206,7 @@ (string-append "\"" file-name "\"")) file-names))) - (define (get-selection self for-scheme-mode?) + (define (get-selection self for-scheme-mode? focus-object-table) (let* ((marked (select-list-get-selection select-list)) (file-names (map fs-object-complete-path diff --git a/scheme/inspector.scm b/scheme/inspector.scm index fb9b8d1..85650df 100644 --- a/scheme/inspector.scm +++ b/scheme/inspector.scm @@ -165,7 +165,7 @@ (string-join (map exp->string (map make-reference marked))) ")")))) - (define (get-selection self for-scheme-mode?) + (define (get-selection self for-scheme-mode? focus-object-table) (if for-scheme-mode? (let ((marked (select-list-get-selection selection-list))) (prepare-selection-for-scheme-mode marked)) diff --git a/scheme/job-viewer.scm b/scheme/job-viewer.scm new file mode 100644 index 0000000..402ca36 --- /dev/null +++ b/scheme/job-viewer.scm @@ -0,0 +1,107 @@ +(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?)) diff --git a/scheme/job.scm b/scheme/job.scm index ad58b03..99a0722 100644 --- a/scheme/job.scm +++ b/scheme/job.scm @@ -1,19 +1,26 @@ (define-record-type job :job - (really-make-job name pty-in pty-out proc status) + (really-make-job name pty-in pty-out proc + status + start-time end-time + run-status) job? (name job-name) (pty-in job-pty-in) (pty-out job-pty-out) (proc job-proc) - (status really-job-status)) + (status really-job-status) + (start-time job-start-time) + (end-time job-end-time set-job-end-time!) + (run-status job-run-status set-job-run-status!)) (define-record-discloser :job (lambda (r) - `(job ,(job-name r)))) + `(job ,(job-name r) ,(job-run-status r)))) (define (make-job name pty-in pty-out proc) - (let ((job (really-make-job name pty-in pty-out proc - (make-placeholder)))) + (let ((job (really-make-job + name pty-in pty-out proc (make-placeholder) + (date) #f 'running))) (spawn-job-status-surveillant job) (add-job! job) job)) @@ -28,8 +35,23 @@ (let ((channel (make-channel))) (spawn (lambda () - (placeholder-set! - (really-job-status job) (wait (job-proc job))))))) + (let ((status (wait (job-proc job)))) + (set-job-end-time! job (date)) + (set-job-run-status! job 'ready) + (placeholder-set! + (really-job-status job) status)))))) + +(define (job-running? job) + (eq? (job-run-status job) 'running)) + +(define (job-ready? job) + (eq? (job-run-status job) 'ready)) + +(define (job-waiting-for-input? job) + (eq? (job-run-status job) 'waiting-for-input)) + +(define (job-has-new-output? job) + (eq? (job-run-status job) 'new-output)) (define (signal-job signal job) (signal-process-group signal (job-proc job))) @@ -143,3 +165,5 @@ (exec-epf epf)))) (lambda (proc pty-in pty-out tty-name) (make-job (quote epf) pty-in pty-out proc)))))) + +;;; EOF diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 16ea7c0..f449681 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -292,7 +292,9 @@ (define (paste-selection/refresh viewer) (add-string-to-command-buffer - (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?))) + (send (current-viewer) + 'get-selection + (command-buffer-in-scheme-mode?) (focus-table))) (print-command-buffer (app-window-curses-win command-window) command-buffer) (move-cursor command-buffer result-buffer) @@ -301,7 +303,10 @@ (define (paste-focus-object/refresh viewer) (add-string-to-command-buffer (if (command-buffer-in-command-mode?) - (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?)) + (send (current-viewer) + 'get-selection + (command-buffer-in-scheme-mode?) + (focus-table)) (send (current-viewer) 'get-focus-object (focus-table)))) (print-command-buffer (app-window-curses-win command-window) command-buffer) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 8c59eec..ab01bbd 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -138,6 +138,7 @@ srfi-1 srfi-13 + joblist fs-object pps nuit-eval @@ -196,20 +197,43 @@ select-list-selected-entry select-list-navigation-key? - select-list-marking-key?)) + select-list-marking-key? + + make-get-focus-object-method)) (define-structure select-list select-list-interface (open scheme srfi-1 + (subset srfi-13 (string-join)) define-record-types signals - + + (subset focus-table (make-focus-object-reference)) tty-debug plugin layout ncurses) (files select-list)) +;;; joblist viewer + +(define-structure joblist-viewer + (export) + (open scheme-with-scsh + srfi-1 + srfi-6 + (subset srfi-13 (string-join)) + signals + + objects + jobs + ncurses + focus-table + select-list + plugin + layout) + (files job-viewer)) + ;;; inspector (define-interface nuit-inspector-interface @@ -336,6 +360,17 @@ (export make-job job-status job-status-rv + + job? + job-running? + job-ready? + job-waiting-for-input? + job-has-new-output? + job-start-time + job-end-time + job-proc + job-name + signal-job stop-job continue-job @@ -409,6 +444,7 @@ jobs joblist ;; the following modules are plugins + joblist-viewer dirlist-view-plugin user-group-info-plugin process-viewer diff --git a/scheme/process.scm b/scheme/process.scm index c70a22e..56e9732 100644 --- a/scheme/process.scm +++ b/scheme/process.scm @@ -48,7 +48,7 @@ processes)) (header (make-header-line (result-buffer-num-cols buffer)))) - (define (get-selection self for-scheme-mode?) + (define (get-selection self for-scheme-mode? focus-object-table) (let ((marked (select-list-get-selection select-list))) (if (null? marked) (number->string @@ -57,19 +57,6 @@ (string-append "'"(exp->string (map process-info-pid marked)))))) - (define (get-focus-object self focus-object-table) - (let ((marked (select-list-get-selection select-list)) - (make-reference (lambda (obj) - (make-focus-object-reference - focus-object-table obj)))) - (if (null? marked) - (exp->string - (make-reference (select-list-selected-entry select-list))) - (string-append - "(list " - (string-join (map exp->string (map make-reference marked))) - ")")))) - (lambda (message) (case message @@ -88,7 +75,8 @@ ((get-selection) get-selection) - ((get-focus-object) get-focus-object) + ((get-focus-object) + (make-get-focus-object-method select-list)) (else (error "pps-viewer unknown message" message)))))) diff --git a/scheme/select-list.scm b/scheme/select-list.scm index 3dd4ff6..1b12e53 100644 --- a/scheme/select-list.scm +++ b/scheme/select-list.scm @@ -173,4 +173,19 @@ (define (select-list-selected-entry select-list) (element-value (list-ref (select-list-elements select-list) - (select-list-cursor-index select-list)))) \ No newline at end of file + (select-list-cursor-index select-list)))) + +(define (make-get-focus-object-method select-list) + (lambda (self focus-object-table) + (let ((marked (select-list-get-selection select-list)) + (make-reference (lambda (obj) + (make-focus-object-reference + focus-object-table obj)))) + (if (null? marked) + (exp->string + (make-reference (select-list-selected-entry select-list))) + (string-append + "(list " + (string-join (map exp->string (map make-reference marked))) + ")"))))) + diff --git a/scheme/std-command.scm b/scheme/std-command.scm index 2e78438..10b4b91 100644 --- a/scheme/std-command.scm +++ b/scheme/std-command.scm @@ -139,6 +139,17 @@ (make-command-plugin "exit" no-completer (lambda (command args) + (clear) (exit (if (null? args) 0 - (string->number (car args))))))) \ No newline at end of file + (string->number (car args))))))) + +(register-plugin! + (make-command-plugin "jobs" + no-completer + (lambda (command args) + (append + (running-jobs) (ready-jobs) + (jobs-with-new-output) + (jobs-waiting-for-input))))) +