bug#59407: [PATCH] Add Colors to proced

[Laurence Warne <laurencewarne@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 1965 bytes --]

Thanks for all the feedback, I have a few queries.

> Thanks.  Please be sure to test the new faces with the following Emacs
> configurations:
>
>   . GUI frames with dark background
>   . GUI frames with light background
>   . TTY frames with dark and light backgrounds and with:
>     - 8 colors
>     - 16 colors
>

Do you know if there's an easy way I can test the faces on 8/16 colour
terminals?

>   (proced-run-status-code, proced-executable. proced-memory-default)
>   (proced-memory-mb, proced-pgrp): New faces.
>
Minor, but do you mean to add a closing paren at the end of each line?  I
saw this format in the commit log:
  (proced-run-status-code, proced-executable. proced-memory-default,
  proced-memory-mb, proced-pgrp): New faces.

This should probably be specified as percentage of total memory.  Or maybe
> there should be a separate defcustom for the percentage, and the condition
> should use both.  Just a single absolute threshold seems to cover only some
> reasons for highlighting processes with large memory footprint.
>

I was thinking highlighting based on percentage memory would be more suited
to the "mem" process attribute (granted though this is not implemented).
Though in hindsight a global threshold may not make sense if you're
connecting to remote systems with varying amounts of RAM.  Perhaps the two
thresholds could mark a percentage, say 10% and 50% of total memory?

I haven't tried your patch, but I'm curious whether it works also for
> proced buffers of remote systems.
>
Hi Michael, I did a quick check yesterday and it seemed to work as expected.

This should happen only for proced running on the local system.
>
Thanks, this should be fixed in the most recent patch.

I've attached a more up to date patch, with changes to faces (mainly adding
better defaults for light backgrounds), and a NEWS entry.  Also attached
are images showing the current colour schemes on light backgrounds and
terminals.

Thanks, Laurence

[-- Attachment #1.2: Type: text/html, Size: 3024 bytes --]

[-- Attachment #2: proced-colors-light-1.png --]
[-- Type: image/png, Size: 355474 bytes --]

[-- Attachment #3: proced-colors-terminal-dark.png --]
[-- Type: image/png, Size: 333988 bytes --]

[-- Attachment #4: proced-terminal-light.png --]
[-- Type: image/png, Size: 323526 bytes --]

[-- Attachment #5: 0001-Add-colors-to-proced.patch --]
[-- Type: text/x-patch, Size: 16713 bytes --]

From a9494167cef53d6c25d224caa444560cd556dd23 Mon Sep 17 00:00:00 2001
From: Laurence Warne <laurencewarne@gmail.com>
Date: Wed, 16 Nov 2022 14:32:44 +0000
Subject: [PATCH] Add colors to proced

Add a new custom variable proced-enable-color-flag which when set to a
non-nil value (defaults to nil), will prompt some format functions to
furnish their respective process attributes with colors and effects in
order to make them easier to distinguish and highlight possible issues
(e.g. high memory usage), in a manner similar to htop.

In particular, the current Emacs process id is highlighted purple in
both the process id and parent process id columns, session leaders
have their process ids underlined, larger memory sizes for rss and
vsize are highlighted in darker shades of orange, and the first word
in the args property (the executable) is highlighted in blue.

* lisp/proced.el (proced-grammar-alist): Update to use the new format
functions.
(proced-low-memory-usage-threshold): New custom variable to determine
whether a value represents 'low' memory usage, used only in
proced-format-memory for coloring.
(proced-medium-memory-usage-threshold): New custom variable to determine
whether a value represents 'medium' memory usage, used only in
proced-format-memory for coloring.
(proced-enable-color-flag): New custom variable to toggle coloring.
(proced-run-status-code, proced-interruptible-sleep-status-code,
proced-uninterruptible-sleep-status-code, proced-executable,
proced-executable, proced-memory-gb, proced-memory-mb,
proced-memory-default, proced-pid, proced-ppid, proced-pgrp,
proced-sess, proced-cpu, proced-mem, proced-user, proced-time-colon):
New faces.
(proced-format-time): Edit function to color colons using proced-time-colon.
(proced-format-args): Edit function to color executables using
proced-executable.
(proced-format-state): New function to color states.
(proced-format-pid): New function to color process ids.
(proced-format-ppid): New function to color parent process ids.
(proced-format-pgrp): New function to color process group ids.
(proced-format-sess): New function to color process session leader ids.
(proced-format-cpu): New function to color cpu utilization.
(proced-format-mem): New function to color memory utilization.
(proced-format-user): New function to color the user a process belongs to.
---
 etc/NEWS       |  16 ++++
 lisp/proced.el | 242 +++++++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 242 insertions(+), 16 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 4c7af3c276..e41bab14de 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -514,6 +514,22 @@ option) and can be set to nil to disable Just-in-time Lock mode.
 \f
 * Changes in Emacs 29.1
 
+---
+** New user option `proced-enable-color-flag` to enable coloring of proced buffers
+This option enables prompts some format functions to furnish their
+respective process attributes with colors and effects in order to
+make them easier to distinguish and highlight possible issues
+(e.g. high memory usage), in a manner similar to htop.
+
+In particular, the current Emacs process id is highlighted purple in
+both the process id and parent process id columns, session leaders
+have their process ids underlined, larger memory sizes for rss and
+vsize are highlighted in darker shades of orange, and the first word
+in the args property (the executable) is highlighted in blue.
+
+Note this option is disabled by default and needs setting to a non-nil
+value to take effect.
+
 +++
 ** New user option 'major-mode-remap-alist' to specify favorite major modes.
 This user option lets you remap the default modes (e.g. 'perl-mode' or
diff --git a/lisp/proced.el b/lisp/proced.el
index a6f1a71778..b6e0897638 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -114,16 +114,16 @@ proced-signal-list
 (defcustom proced-grammar-alist
   '( ;; attributes defined in `process-attributes'
     (euid    "EUID"    "%d" right proced-< nil (euid pid) (nil t nil))
-    (user    "User"    nil left proced-string-lessp nil (user pid) (nil t nil))
+    (user    "User"    proced-format-user left proced-string-lessp nil (user pid) (nil t nil))
     (egid    "EGID"    "%d" right proced-< nil (egid euid pid) (nil t nil))
     (group   "Group"   nil left proced-string-lessp nil (group user pid) (nil t nil))
     (comm    "Command" nil left proced-string-lessp nil (comm pid) (nil t nil))
-    (state   "Stat"    nil left proced-string-lessp nil (state pid) (nil t nil))
-    (ppid    "PPID"    "%d" right proced-< nil (ppid pid)
+    (state   "Stat"    proced-format-state left proced-string-lessp nil (state pid) (nil t nil))
+    (ppid    "PPID"    proced-format-ppid right proced-< nil (ppid pid)
              ((lambda (ppid) (proced-filter-parents proced-process-alist ppid))
               "refine to process parents"))
-    (pgrp    "PGrp"    "%d" right proced-< nil (pgrp euid pid) (nil t nil))
-    (sess    "Sess"    "%d" right proced-< nil (sess pid) (nil t nil))
+    (pgrp    "PGrp"    proced-format-pgrp right proced-< nil (pgrp euid pid) (nil t nil))
+    (sess    "Sess"    proced-format-sess right proced-< nil (sess pid) (nil t nil))
     (ttname  "TTY"     proced-format-ttname left proced-string-lessp nil (ttname pid) (nil t nil))
     (tpgid   "TPGID"   "%d" right proced-< nil (tpgid pid) (nil t nil))
     (minflt  "MinFlt"  "%d" right proced-< nil (minflt pid) (nil t t))
@@ -143,12 +143,12 @@ proced-grammar-alist
     (vsize   "VSize"   proced-format-memory right proced-< t (vsize pid) (nil t t))
     (rss     "RSS"     proced-format-memory right proced-< t (rss pid) (nil t t))
     (etime   "ETime"   proced-format-time right proced-time-lessp t (etime pid) (nil t t))
-    (pcpu    "%CPU"    "%.1f" right proced-< t (pcpu pid) (nil t t))
-    (pmem    "%Mem"    "%.1f" right proced-< t (pmem pid) (nil t t))
+    (pcpu    "%CPU"    proced-format-cpu right proced-< t (pcpu pid) (nil t t))
+    (pmem    "%Mem"    proced-format-mem right proced-< t (pmem pid) (nil t t))
     (args    "Args"    proced-format-args left proced-string-lessp nil (args pid) (nil t nil))
     ;;
     ;; attributes defined by proced (see `proced-process-attributes')
-    (pid     "PID"     "%d" right proced-< nil (pid)
+    (pid     "PID"     proced-format-pid right proced-< nil (pid)
              ((lambda (ppid) (proced-filter-children proced-process-alist ppid))
               "refine to process children"))
     ;; process tree
@@ -367,6 +367,30 @@ proced-after-send-signal-hook
   :type 'hook
   :options '(proced-revert))
 
+(defcustom proced-enable-color-flag nil
+  "Non-nil means some process attributes will be displayed with color."
+  :type 'boolean
+  :version "29.1")
+
+(defcustom proced-low-memory-usage-threshold (* 1024 1024 100)
+  "The low memory usage (in bytes) upper bound.
+
+When `proced-enable-color-flag' is non-nil, vsize and rss values less than
+this value will be displayed using the `proced-memory-low-usage' face."
+  :type 'integer
+  :version "29.1")
+
+(defcustom proced-medium-memory-usage-threshold (* 1024 1024 1024)
+  "The medium memory usage (in bytes) upper bound.
+
+When `proced-enable-color-flag' is non-nil, vsize and rss values less than
+this value, but greater than `proced-low-memory-usage-threshold' will be
+displayed using the `proced-memory-medium-usage' face.  vsize and rss values
+greater than this value will be displayed using the `proced-memory-high-usage'
+face."
+  :type 'integer
+  :version "29.1")
+
 ;; Internal variables
 
 (defvar proced-available t;(not (null (list-system-processes)))
@@ -403,6 +427,106 @@ proced-sort-header
   '((t (:inherit font-lock-keyword-face)))
   "Face used for header of attribute used for sorting.")
 
+(defface proced-run-status-code
+  '((t (:foreground "green")))
+  "Face used for the running or runnable status code character \"R\"."
+  :version "29.1")
+
+(defface proced-interruptible-sleep-status-code
+  '((((class color)) (:foreground "DimGrey"))
+    (t (:italic t)))
+  "Face used for the interruptible sleep status code character \"S\"."
+  :version "29.1")
+
+(defface proced-uninterruptible-sleep-status-code
+  '((((class color)) (:foreground "red"))
+    (t (:bold t)))
+  "Face used for the uninterruptible sleep status code character \"D\"."
+  :version "29.1")
+
+(defface proced-executable
+  '((((class color) (background dark)) (:foreground "DeepSkyBlue"))
+    (t (:foreground "blue")))
+  "Face for executables (first word in the args process attribute)."
+  :version "29.1")
+
+(defface proced-memory-high-usage
+  '((((class color) (background dark)) (:foreground "orange"))
+    (((class color) (background light)) (:foreground "OrangeRed"))
+    (t (:bold t)))
+  "Face for high memory usage."
+  :version "29.1")
+
+(defface proced-memory-medium-usage
+  '((((class color) (background dark)) (:foreground "yellow3"))
+    (((class color) (background light)) (:foreground "orange")))
+  "Face for medium memory usage."
+  :version "29.1")
+
+(defface proced-memory-low-usage
+  '((((background dark) (min-colors 88)) (:foreground "#8bcd50"))
+    (((class color) (background light)) (:foreground "green")))
+  "Face for low memory usage."
+  :version "29.1")
+
+(defface proced-emacs-pid
+  '((t (:foreground "purple")))
+  "Face for the pid of the current Emacs process."
+  :version "29.1")
+
+(defface proced-pid
+  '((((class color) (min-colors 88)) (:foreground "#5085ef"))
+    (((class color)) (:foreground "blue")))
+  "Face for process ids."
+  :version "29.1")
+
+(defface proced-session-leader-pid
+  '((((class color) (min-colors 88)) (:foreground "#5085ef" :underline t))
+    (((class color)) (:foreground "blue" :underline t))
+    (t (:underline t)))
+  "Face for process ids which are session leaders."
+  :version "29.1")
+
+(defface proced-ppid
+  '((((class color) (min-colors 88)) (:foreground "#5085bf"))
+    (((class color)) (:foreground "blue")))
+  "Face for parent process ids."
+  :version "29.1")
+
+(defface proced-pgrp
+  '((((class color) (min-colors 88)) (:foreground "#4785bf"))
+    (((class color)) (:foreground "blue")))
+  "Face for process group ids."
+  :version "29.1")
+
+(defface proced-sess
+  '((((class color) (min-colors 88)) (:foreground "#41729f")))
+  "Face for process session ids."
+  :version "29.1")
+
+(defface proced-cpu
+  '((((class color) (min-colors 88)) (:foreground "#6d5cc3" :bold t))
+    (t (:bold t)))
+  "Face for process cpu utilization."
+  :version "29.1")
+
+(defface proced-mem
+  '((((class color) (min-colors 88))
+     (:foreground "#6d5cc3")))
+  "Face for process memory utilization."
+  :version "29.1")
+
+(defface proced-user
+  '((t (:bold t)))
+  "Face for the user."
+  :version "29.1")
+
+(defface proced-time-colon
+  '((((class color)) (:foreground "DarkMagenta"))
+    (t (:bold t)))
+  "Face for the colon in time strings."
+  :version "29.1")
+
 (defvar proced-re-mark "^[^ \n]"
   "Regexp matching a marked line.
 Important: the match ends just after the marker.")
@@ -1386,26 +1510,32 @@ proced-format-time
          (hours (truncate ftime 3600))
          (ftime (mod ftime 3600))
          (minutes (truncate ftime 60))
-         (seconds (mod ftime 60)))
+         (seconds (mod ftime 60))
+         (colon (if proced-enable-color-flag
+                    (propertize ":" 'font-lock-face 'proced-time-colon)
+                  ":")))
     (cond ((< 0 days)
-           (format "%d-%02d:%02d:%02d" days hours minutes seconds))
+           (format "%d-%02d%3$s%02d%3$s%02d" days hours colon minutes seconds))
           ((< 0 hours)
-           (format "%02d:%02d:%02d" hours minutes seconds))
+           (format "%02d%2$s%02d%2$s%02d" hours colon minutes seconds))
           (t
-           (format "%02d:%02d" minutes seconds)))))
+           (format "%02d%s%02d" minutes colon seconds)))))
 
 (defun proced-format-start (start)
   "Format time START.
 The return string is always 6 characters wide."
   (let ((d-start (decode-time start))
-        (d-current (decode-time)))
+        (d-current (decode-time))
+        (colon (if proced-enable-color-flag
+                   (propertize ":" 'font-lock-face 'proced-time-colon)
+                 ":")))
     (cond (;; process started in previous years
            (< (decoded-time-year d-start) (decoded-time-year d-current))
            (format-time-string "  %Y" start))
           ;; process started today
           ((and (= (decoded-time-day d-start) (decoded-time-day d-current))
                 (= (decoded-time-month d-start) (decoded-time-month d-current)))
-           (format-time-string " %H:%M" start))
+           (string-replace ":" colon (format-time-string " %H:%M" start)))
           (t ;; process started this year
            (format-time-string "%b %e" start)))))
 
@@ -1423,11 +1553,91 @@ proced-format-tree
 (defun proced-format-args (args)
   "Format attribute ARGS.
 Replace newline characters by \"^J\" (two characters)."
-  (string-replace "\n" "^J" args))
+  (string-replace "\n" "^J"
+                  (pcase-let* ((`(,exe . ,rest) (split-string args))
+                               (exe-prop (if proced-enable-color-flag
+                                             (propertize exe 'font-lock-face 'proced-executable)
+                                           exe)))
+                    (mapconcat #'identity (cons exe-prop rest) " "))))
 
 (defun proced-format-memory (kilobytes)
   "Format KILOBYTES in a human readable format."
-  (funcall byte-count-to-string-function (* 1024 kilobytes)))
+  (let* ((bytes (* 1024 kilobytes))
+         (formatted (funcall byte-count-to-string-function bytes)))
+    (cond ((and proced-enable-color-flag (< bytes proced-low-memory-usage-threshold))
+           (propertize formatted 'font-lock-face 'proced-memory-low-usage))
+          ((and proced-enable-color-flag (< bytes proced-medium-memory-usage-threshold))
+           (propertize formatted 'font-lock-face 'proced-memory-medium-usage))
+          (proced-enable-color-flag
+           (propertize formatted 'font-lock-face 'proced-memory-high-usage))
+          (t formatted))))
+
+(defun proced-format-state (state)
+  "Format STATE."
+  (cond ((and proced-enable-color-flag (string= state "R"))
+         (propertize state 'font-lock-face 'proced-run-status-code))
+        ((and proced-enable-color-flag (string= state "S"))
+         (propertize state 'font-lock-face 'proced-interruptible-sleep-status-code))
+        ((and proced-enable-color-flag (string= state "D"))
+         (propertize state 'font-lock-face 'proced-uninterruptible-sleep-status-code))
+        (t state)))
+
+(defun proced-format-pid (pid)
+  "Format PID."
+  (let ((proc-info (process-attributes pid))
+        (pid-s (number-to-string pid)))
+    (cond ((and proced-enable-color-flag
+                (not (file-remote-p default-directory))
+                (equal pid (emacs-pid)))
+           (propertize pid-s 'font-lock-face 'proced-emacs-pid))
+          ((and proced-enable-color-flag (equal pid (alist-get 'sess proc-info)))
+           (propertize pid-s 'font-lock-face 'proced-session-leader-pid))
+          (proced-enable-color-flag
+           (propertize pid-s 'font-lock-face 'proced-pid))
+          (t pid-s))))
+
+(defun proced-format-ppid (ppid)
+  "Format PPID."
+  (let ((ppid-s (number-to-string ppid)))
+    (cond ((and proced-enable-color-flag
+                (not (file-remote-p default-directory))
+                (= ppid (emacs-pid)))
+           (propertize ppid-s 'font-lock-face 'proced-emacs-pid))
+          (proced-enable-color-flag
+           (propertize ppid-s 'font-lock-face 'proced-ppid))
+          (t ppid-s))))
+
+(defun proced-format-pgrp (pgrp)
+  "Format PGRP."
+  (if proced-enable-color-flag
+      (propertize (number-to-string pgrp) 'font-lock-face 'proced-pgrp)
+    (number-to-string pgrp)))
+
+(defun proced-format-sess (sess)
+  "Format SESS."
+  (if proced-enable-color-flag
+      (propertize (number-to-string sess) 'font-lock-face 'proced-sess)
+    (number-to-string sess)))
+
+(defun proced-format-cpu (cpu)
+  "Format CPU."
+  (let ((formatted (format "%.1f" cpu)))
+    (if proced-enable-color-flag
+        (propertize formatted 'font-lock-face 'proced-cpu)
+      formatted)))
+
+(defun proced-format-mem (mem)
+  "Format MEM."
+  (let ((formatted (format "%.1f" mem)))
+    (if proced-enable-color-flag
+        (propertize formatted 'font-lock-face 'proced-mem)
+      formatted)))
+
+(defun proced-format-user (user)
+  "Format USER."
+  (if proced-enable-color-flag
+      (propertize user 'font-lock-face 'proced-user)
+    user))
 
 (defun proced-format (process-alist format)
   "Display PROCESS-ALIST using FORMAT."
-- 
2.30.2