bug#59407: [PATCH] Add Colors to proced

[Laurence Warne <laurencewarne@gmail.com>]

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

Hi Eli,

Thanks for taking another look.

> Is this color visible well on both dark and light backgrounds?

I think it looks good on both, I've attached a couple of images to
hopefully highlight this (in the STAT column), let me know what you think.
Hopefully the attached patch addresses all of the rest of your comments.

> I've pushed a respective change to master. On remote GNU/Linux or *BSD
> systems, memory-info shall return the appropriate values now. On other
> remote systems it returns nil.

Nice, the new patch should take this into consideration.

Thanks, Laurence

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

[-- Attachment #2: proced-colours-1.png --]
[-- Type: image/png, Size: 471177 bytes --]

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

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

From 5283278e270f47a0bd5b5063452b899dc030a400 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
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       |   8 ++
 lisp/proced.el | 255 +++++++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 247 insertions(+), 16 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 85fdf005e3..7953996a62 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -509,6 +509,14 @@ 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 prompts some format functions to furnish their respective
+process attributes with colors in a manner similar to htop.
+
+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 ac44ae1513..f91d3d2f22 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))
@@ -141,14 +141,14 @@ proced-grammar-alist
     (thcount "THCount" "%d" right proced-< t (thcount pid) (nil t t))
     (start   "Start"   proced-format-start 6 proced-time-lessp nil (start pid) (t t nil))
     (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))
+    (rss     "RSS"     proced-format-rss 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,32 @@ proced-after-send-signal-hook
   :type 'hook
   :options '(proced-revert))
 
+(defcustom proced-enable-color-flag nil
+  "Non-nil means Proced should display some process attributes with color."
+  :type 'boolean
+  :version "29.1")
+
+(defcustom proced-low-memory-usage-threshold 0.1
+  "The upper bound for low memory usage, relative to total memory.
+
+When `proced-enable-color-flag' is non-nil, RSS values denoting a proportion
+of memory lower than this value will be displayed using the
+`proced-memory-low-usage' face."
+  :type 'float
+  :version "29.1")
+
+(defcustom proced-medium-memory-usage-threshold 0.5
+  "The upper bound for medium memory usage, relative to total memory.
+
+When `proced-enable-color-flag' is non-nil, RSS values denoting a proportion
+of memory less than this value, but greater than
+`proced-low-memory-usage-threshold', will be displayed using the
+`proced-memory-medium-usage' face.  RSS values denoting a greater proportion
+than this value will be displayed using the `proced-memory-high-usage'
+face."
+  :type 'float
+  :version "29.1")
+
 ;; Internal variables
 
 (defvar proced-available t;(not (null (list-system-processes)))
@@ -403,6 +429,112 @@ 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 in Proced buffers for the running or runnable status code character \"R\"."
+  :version "29.1")
+
+(defface proced-interruptible-sleep-status-code
+  '((((class color) (min-colors 88)) (:foreground "DimGrey"))
+    (t (:italic t)))
+  "Face used in Proced buffers 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 in Proced buffers for the uninterruptible sleep status code character \"D\"."
+  :version "29.1")
+
+(defface proced-executable
+  '((((class color) (min-colors 88) (background dark)) (:foreground "DeepSkyBlue"))
+    (((class color) (background dark)) (:foreground "cyan"))
+    (((class color) (background light)) (:foreground "blue"))
+    (t (:bold t)))
+  "Face used in Proced buffers for executables (first word in the args process attribute)."
+  :version "29.1")
+
+(defface proced-memory-high-usage
+  '((((class color) (min-colors 88) (background dark)) (:foreground "orange"))
+    (((class color) (min-colors 88) (background light)) (:foreground "OrangeRed"))
+    (((class color)) (:foreground "red"))
+    (t (:underline t)))
+  "Face used in Proced buffers for high memory usage."
+  :version "29.1")
+
+(defface proced-memory-medium-usage
+  '((((class color) (min-colors 88) (background dark)) (:foreground "yellow3"))
+    (((class color) (min-colors 88) (background light)) (:foreground "orange"))
+    (((class color)) (:foreground "yellow")))
+  "Face used in Proced buffers for medium memory usage."
+  :version "29.1")
+
+(defface proced-memory-low-usage
+  '((((class color) (min-colors 88) (background dark)) (:foreground "#8bcd50"))
+    (((class color)) (:foreground "green")))
+  "Face used in Proced buffers for low memory usage."
+  :version "29.1")
+
+(defface proced-emacs-pid
+  '((((class color) (min-colors 88)) (:foreground "purple"))
+    (((class color)) (:foreground "magenta")))
+  "Face used in Proced buffers for the process ID of the current Emacs process."
+  :version "29.1")
+
+(defface proced-pid
+  '((((class color) (min-colors 88)) (:foreground "#5085ef"))
+    (((class color)) (:foreground "blue")))
+  "Face used in Proced buffers 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 used in Proced buffers 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 used in Proced buffers for parent process IDs."
+  :version "29.1")
+
+(defface proced-pgrp
+  '((((class color) (min-colors 88)) (:foreground "#4785bf"))
+    (((class color)) (:foreground "blue")))
+  "Face used in Proced buffers for process group IDs."
+  :version "29.1")
+
+(defface proced-sess
+  '((((class color) (min-colors 88)) (:foreground "#41729f"))
+    (((class color)) (:foreground "MidnightBlue")))
+  "Face used in Proced buffers for process session IDs."
+  :version "29.1")
+
+(defface proced-cpu
+  '((((class color) (min-colors 88)) (:foreground "#6d5cc3" :bold t))
+    (t (:bold t)))
+  "Face used in Proced buffers for process CPU utilization."
+  :version "29.1")
+
+(defface proced-mem
+  '((((class color) (min-colors 88))
+     (:foreground "#6d5cc3")))
+  "Face used in Proced buffers for process memory utilization."
+  :version "29.1")
+
+(defface proced-user
+  '((t (:bold t)))
+  "Face used in Proced buffers for the user owning the process."
+  :version "29.1")
+
+(defface proced-time-colon
+  '((((class color) (min-colors 88)) (:foreground "DarkMagenta"))
+    (t (:bold t)))
+  "Face used in Proced buffers 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.")
@@ -1392,26 +1524,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)))))
 
@@ -1429,12 +1567,97 @@ 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)))
 
+(defun proced-format-rss (kilobytes)
+  "Format RSS KILOBYTES in a human readable format."
+  (let ((formatted (proced-format-memory kilobytes)))
+    (if-let* ((proced-enable-color-flag)
+              (total (car (memory-info)))
+              (proportion (/ (float kilobytes) total)))
+        (cond ((< proportion proced-low-memory-usage-threshold)
+               (propertize formatted 'font-lock-face 'proced-memory-low-usage))
+              ((< proportion proced-medium-memory-usage-threshold)
+               (propertize formatted 'font-lock-face 'proced-memory-medium-usage))
+              (t (propertize formatted 'font-lock-face 'proced-memory-high-usage)))
+      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."
   (if (symbolp format)
-- 
2.30.2