(define (list-of-processes? thing)
  (and (proper-list? thing)
       (every process-info? thing)))

(define (make-header-line width)
  (make-select-line
   (list
    (right-align-string 6 "PID ")
    (right-align-string 6 "PPID ")
    (left-align-string 9 "USER ")
    (right-align-string 6 "TIME ")
    "COMMAND")
   width))

(define (layout-process width p)
  (cut-to-size 
   width
   (string-append
    (right-align-string 5 (number->string (process-info-pid p)))
    " "
    (right-align-string 5 (number->string (process-info-ppid p)))
    " "
    (left-align-string 8 (process-info-logname p))
    " "
    (right-align-string 5 (number->string (process-info-time p)))
    " "
    (left-align-string 100 (string-append
                           (process-info-executable p)
                           " "
                           (string-join 
                            (process-info-command-line p)))))))

(define (make-process-selection-list num-cols num-lines 
                                     processes)
  (let ((layout (lambda (p) (layout-process num-cols p))))
    (make-select-list
     (map 
      (lambda (p)
        (make-unmarked-text-element p #t (layout-process num-cols p)))
      processes)
     num-lines)))

(define-option 'ps 'sort-user-up-key (char->ascii #\u))
(define-option 'ps 'sort-user-down-key (char->ascii #\U))
(define-option 'ps 'sort-pid-up-key (char->ascii #\p))
(define-option 'ps 'sort-pid-down-key (char->ascii #\P))
(define-option 'ps 'sort-time-up-key (char->ascii #\t))
(define-option 'ps 'sort-time-down-key (char->ascii #\T))
(define-option 'ps 'kill-key (char->ascii #\k))
(define-option 'ps 'refresh-key (char->ascii #\g))

(define (make-pps-viewer processes buffer)
  (let* ((processes processes)
         (header-line (make-header-line (result-buffer-num-cols buffer)))
         (select-list
          (make-process-selection-list 
           (result-buffer-num-cols buffer)
           (result-buffer-num-lines buffer)
           processes)))

    (define sorting-keys
      (map
       (cut config 'ps <>)
       (list 'sort-time-up-key
             'sort-time-down-key
             'sort-user-up-key
             'sort-user-down-key
             'sort-pid-up-key
             'sort-pid-down-key)))

    (define (set-processes! new-processes)
      (set! processes new-processes)
      (set! select-list
            (make-process-selection-list 
             (result-buffer-num-cols buffer)
             (- (result-buffer-num-lines buffer) 1)
             new-processes)))

    (define (get-selection-as-text self for-scheme-mode? focus-object-table)
      (let* ((marked (select-list-get-marked select-list)))
	(cond
	 ((null? marked)
	  (number->string 
	   (process-info-pid
	    (select-list-selected-entry select-list))))
	 (for-scheme-mode?
	  (string-append
	   "'" (write-to-string (map process-info-pid marked))))
	 (else
	  (string-join 
	   (map number->string
		(map process-info-pid marked)))))))

    (lambda (message)
      (case message

       ((paint)
	(lambda (self win buffer have-focus?)
          (paint-select-line-at header-line 0 0 win)
	  (paint-selection-list-at 
	   select-list 0 1 win buffer have-focus?)))

       ((key-press)
	(lambda (self key control-x-pressed?)
          (cond
           ((member key sorting-keys)
            (receive (compare select)
                (cond
                 ((= key (config 'ps 'sort-time-up-key))
                  (values < process-info-time))
                 ((= key (config 'ps 'sort-time-down-key))
                  (values > process-info-time))
                 ((= key (config 'ps 'sort-user-up-key))
                  (values string<? process-info-logname))
                 ((= key (config 'ps 'sort-user-down-key))
                  (values string>? process-info-logname))
                 ((= key (config 'ps 'sort-pid-up-key))
                  (values < process-info-pid))
                 ((= key (config 'ps 'sort-pid-down-key))
                  (values > process-info-pid)))
              (set-processes!
               (list-sort
                (lambda (p1 p2)
                  (compare (select p1) (select p2)))
                processes))
              self))
           ((= key (config 'ps 'kill-key))
            (let ((infos
                   (select-list-get-selection select-list)))
              (for-each
               (cut signal-process <> signal/term)
               (map process-info-pid infos)))
            self)
           ((= key (config 'ps 'refresh-key))
            (set-processes! (pps))
            self)
           ((select-list-key? key)
            (set! select-list
                  (select-list-handle-key-press select-list key))
            self)
           ((select-line-key? key)
            (select-line-handle-key-press! header-line key)
            self)
           (else self))))

       ((get-selection-as-text) get-selection-as-text)

       ((get-selection-as-ref)
	(make-get-selection-as-ref-method select-list))
       
       (else 
	(error "pps-viewer unknown message" message))))))

(register-plugin! 
 (make-view-plugin make-pps-viewer list-of-processes?))