[nongnu] elpa/hyperdrive fcda78fd06 30/30: Merge branch 'dir-sort-clickable'

[ELPA Syncer]

branch: elpa/hyperdrive
commit fcda78fd069adebf961a099c881c5d0110c74c3a
Merge: 53927eb0a9 eaf2e5104f
Author: Adam Porter <adam@alphapapa.net>
Commit: Adam Porter <adam@alphapapa.net>

    Merge branch 'dir-sort-clickable'
---
 CHANGELOG.org             |   2 +-
 doc/hyperdrive-manual.org |  12 +++---
 hyperdrive-dir.el         | 103 ++++++++++++++++++++++++++++++++--------------
 hyperdrive-history.el     |   4 +-
 hyperdrive-lib.el         |  51 ++++++++---------------
 hyperdrive-vars.el        |  75 ++++++++++++++++++++-------------
 hyperdrive.el             |   2 +
 7 files changed, 147 insertions(+), 102 deletions(-)

diff --git a/CHANGELOG.org b/CHANGELOG.org
index c12d07df58..99ab1f42af 100644
--- a/CHANGELOG.org
+++ b/CHANGELOG.org
@@ -12,7 +12,7 @@ This project adheres to 
[[https://semver.org/spec/v2.0.0.html][Semantic Versioni
 - ~info-look~ integration
 - ~view-mode~ integration
 - Org-mode link completion
-- directory view sorting by column
+- directory view sorting by column (with clickable headers)
 
 ** Changed
 
diff --git a/doc/hyperdrive-manual.org b/doc/hyperdrive-manual.org
index 3140c4344f..e171c3c543 100644
--- a/doc/hyperdrive-manual.org
+++ b/doc/hyperdrive-manual.org
@@ -177,7 +177,8 @@ default:
 #+kindex: revert-buffer
 - ~g~ refreshes the directory to display potential updates
 #+kindex: hyperdrive-dir-sort
-- ~o~ sorts directory contents by column
+- ~o~ sorts directory contents by column (you can also click on the
+  column headers)
 #+kindex: hyperdrive-dir-download-file
 - ~d~ downloads the file at point to disk
 #+kindex: hyperdrive-dir-delete
@@ -474,11 +475,10 @@ customize-group RET hyperdrive RET~:
   for hyperdrive directories. Passed to ~display-buffer~, which see.
 
 #+vindex: hyperdrive-directory-sort
-- ~hyperdrive-directory-sort~ :: Column by which directory entries are
-  sorted.  Internally, a cons cell of (KEY . PREDICATE), the KEY being
-  the `hyperdrive-entry' accessor function and the PREDICATE being the
-  appropriate function (e.g. `time-less-p' for
-  `hyperdrive-entry-mtime', `<' for `hyperdrive-entry-size', etc).
+- ~hyperdrive-directory-sort~ :: Column by which directory entries are sorted.
+Internally, a cons cell of (COLUMN . DIRECTION), the COLUMn being one
+of the directory listing columns (~name~, ~size~, or ~mtime~) and
+DIRECTION being one of ~:ascending~ or ~:descending~.
 
 #+vindex: hyperdrive-history-display-buffer-action
 - ~hyperdrive-history-display-buffer-action~ :: Display buffer action
diff --git a/hyperdrive-dir.el b/hyperdrive-dir.el
index 840597f83e..62daa94009 100644
--- a/hyperdrive-dir.el
+++ b/hyperdrive-dir.el
@@ -120,29 +120,67 @@ arguments."
   "Return column headers as a string with PREFIX.
 Columns are suffixed with up/down arrows according to
 `hyperdrive-sort-entries'."
-  (let (name-arrow size-arrow date-arrow)
-    (pcase-exhaustive hyperdrive-directory-sort
-      (`(hyperdrive-entry-name . ,predicate)
-       (setf name-arrow (pcase-exhaustive predicate
-                          ('string< "▲")
-                          ('string> "▼"))))
-      (`(hyperdrive-entry-size . ,predicate)
-       (setf size-arrow (pcase-exhaustive predicate
-                          ('< "▲")
-                          ('> "▼"))))
-      (`(hyperdrive-entry-mtime . ,predicate)
-       (setf date-arrow (pcase-exhaustive predicate
-                          ('time-less-p "▲")
-                          ((pred functionp) "▼")))))
-    (concat prefix "\n"
-            (format "%6s  %s  %s"
-                    (concat size-arrow
-                            (propertize "Size" 'face 
'hyperdrive-column-header))
-                    (format hyperdrive-timestamp-format-string
-                           (concat date-arrow
-                                   (propertize "Last Modified" 'face 
'hyperdrive-column-header)))
-                    (concat (propertize "Name" 'face 'hyperdrive-column-header)
-                            name-arrow)))))
+  (pcase-let* ((`(,sort-column . ,direction) hyperdrive-directory-sort)
+               ;; TODO: Use "↑" and "↓" glyphs, but make sure that the
+               ;; column headers are aligned correctly.
+               (arrow (propertize (if (eq direction :ascending) "^" "v")
+                                  'face 'hyperdrive-header-arrow))
+               (headers))
+    (pcase-dolist (`(,column . ,(map (:desc desc))) hyperdrive-dir-sort-fields)
+      (let* ((selected (eq column sort-column))
+             ;; Put the arrow after desc, since the column is left-aligned.
+             (left-aligned (eq column 'name))
+             (format-str (pcase column
+                           ('size "%6s")
+                           ('mtime (format "%%%ds" hyperdrive-timestamp-width))
+                           ('name (format "%%-%ds" (- (window-width) 6 2 
hyperdrive-timestamp-width 2)))))
+             (desc (concat (and selected (not left-aligned) arrow)
+                           (and (not left-aligned) " ")
+                           (propertize desc 'face (if selected
+                                                      
'hyperdrive-selected-column-header
+                                                    'hyperdrive-column-header))
+                           ;; This extra space is necessary to prevent
+                           ;; the `hyperdrive-column-header' face from
+                           ;; extended to the end of the window.
+                           (and left-aligned " ")
+                           (and selected left-aligned arrow))))
+        (push (propertize (format format-str desc)
+                          'keymap
+                          (define-keymap
+                            "<mouse-1>" (lambda (&optional _e)
+                                          (interactive "e")
+                                          (hyperdrive-dir-sort
+                                           
(hyperdrive-dir-toggle-sort-direction
+                                            column 
hyperdrive-directory-sort))))
+                          'mouse-face 'highlight)
+              headers)
+        (unless (eq column 'name)
+          ;; These gap spaces are necessary to prevent display mouse-face
+          ;; from activating all contiguous strings simultaneously.
+          (push "  " headers))))
+    (apply #'concat prefix "\n" (nreverse headers))))
+
+
+(defun hyperdrive-dir-complete-sort ()
+  "Return a value for `hyperdrive-directory-sort' selected with completion."
+  (pcase-let* ((read-answer-short t)
+               (choices (mapcar (lambda (field)
+                                  (let ((desc (symbol-name (car field))))
+                                    (list desc (aref desc 0) (format "Sort by 
%s" desc))))
+                                hyperdrive-dir-sort-fields))
+               (column (intern (read-answer "Sort by column: " choices))))
+    (hyperdrive-dir-toggle-sort-direction column hyperdrive-directory-sort)))
+
+(defun hyperdrive-dir-toggle-sort-direction (column sort)
+  "Return `hyperdrive-directory-sort' cons cell for COLUMN.
+If SORT is already sorted using COLUMN, toggle direction.
+Otherwise, set direction to \\+`:descending'."
+  (pcase-let* ((`(,current-column . ,current-direction) sort)
+               (direction (if (and (eq column current-column)
+                                   (eq current-direction :ascending))
+                              :descending
+                            :ascending)))
+    (cons column direction)))
 
 (defun hyperdrive-dir-pp (thing)
   "Pretty-print THING.
@@ -161,7 +199,7 @@ To be used as the pretty-printer for `ewoc-create'."
                        'default))
                (timestamp (if mtime
                               (format-time-string hyperdrive-timestamp-format 
mtime)
-                            (format hyperdrive-timestamp-format-string " "))))
+                            (propertize " " 'display '(space :width 
hyperdrive-timestamp-width)))))
     (format "%6s  %s  %s"
             (propertize (or size "")
                         'face 'hyperdrive-size)
@@ -293,15 +331,16 @@ Interactively, opens file or directory at point in
   "Sort current `hyperdrive-dir' buffer by DIRECTORY-SORT.
 DIRECTORY-SORT should be a valid value of
 `hyperdrive-directory-sort'."
-  (interactive (list (hyperdrive-complete-sort)))
+  (interactive (list (hyperdrive-dir-complete-sort)))
   (setq-local hyperdrive-directory-sort directory-sort)
-  (let ((entries (ewoc-collect hyperdrive-ewoc #'hyperdrive-entry-p)))
-    (ewoc-filter hyperdrive-ewoc #'ignore)
-    (dolist (entry (hyperdrive-sort-entries entries))
-      (ewoc-enter-last hyperdrive-ewoc entry))
-    (ewoc-set-hf hyperdrive-ewoc
-                 (hyperdrive-dir-column-headers (hyperdrive-entry-description 
hyperdrive-current-entry))
-                 "")))
+  (with-silent-modifications
+    (let ((entries (ewoc-collect hyperdrive-ewoc #'hyperdrive-entry-p)))
+      (ewoc-filter hyperdrive-ewoc #'ignore)
+      (dolist (entry (hyperdrive-sort-entries entries))
+        (ewoc-enter-last hyperdrive-ewoc entry))
+      (ewoc-set-hf hyperdrive-ewoc
+                   (hyperdrive-dir-column-headers 
(hyperdrive-entry-description hyperdrive-current-entry))
+                   ""))))
 
 ;;;; Imenu support
 
diff --git a/hyperdrive-history.el b/hyperdrive-history.el
index 27a04e2d38..f814710664 100644
--- a/hyperdrive-history.el
+++ b/hyperdrive-history.el
@@ -60,7 +60,7 @@ and whose cdr is a hyperdrive entry."
                        (file-size-human-readable size)))
                (timestamp (if mtime
                               (format-time-string hyperdrive-timestamp-format 
mtime)
-                            (format hyperdrive-timestamp-format-string " "))))
+                            (propertize " " 'display '(space :width 
hyperdrive-timestamp-width)))))
     ;; FIXME: Use dynamic width of range column equal to 2N+1, where N
     ;; is the width of the hyperdrive's latest version
     (format "%7s  %13s  %6s  %s"
@@ -179,7 +179,7 @@ Universal prefix argument \\[universal-argument] forces
                                            (propertize "Exists?" 'face 
'hyperdrive-column-header)
                                            (propertize "Version Range" 'face 
'hyperdrive-column-header)
                                            (propertize "Size" 'face 
'hyperdrive-column-header)
-                                           (format 
hyperdrive-timestamp-format-string
+                                           (format (format "%%%ds" 
hyperdrive-timestamp-width)
                                                    (propertize "Last Modified" 
'face 'hyperdrive-column-header)))))
                    (queue) (ewoc))
         (with-current-buffer (get-buffer-create
diff --git a/hyperdrive-lib.el b/hyperdrive-lib.el
index 6068b5f3db..86c72105ac 100644
--- a/hyperdrive-lib.el
+++ b/hyperdrive-lib.el
@@ -128,15 +128,18 @@ generated from PATH.  When ENCODE is non-nil, encode 
PATH."
    :version version
    :etc etc))
 
-(cl-defun hyperdrive-sort-entries (entries &key (by hyperdrive-directory-sort))
-  "Return ENTRIES sorted by BY.
-See `hyperdrive-directory-sort' for the type of BY."
-  (cl-sort entries (lambda (a b)
-                     (cond ((and a b) (funcall (cdr by) a b))
-                           ;; When an entry lacks appropriate metadata
-                           ;; for sorting with BY, put it at the end.
-                           (a t)))
-           :key (car by)))
+(cl-defun hyperdrive-sort-entries (entries &key (direction 
hyperdrive-directory-sort))
+  "Return ENTRIES sorted by DIRECTION.
+See `hyperdrive-directory-sort' for the type of DIRECTION."
+  (pcase-let* ((`(,column . ,direction) direction)
+               ((map (:accessor accessor) (direction sort-function))
+                (alist-get column hyperdrive-dir-sort-fields)))
+    (cl-sort entries (lambda (a b)
+                       (cond ((and a b) (funcall sort-function a b))
+                             ;; When an entry lacks appropriate metadata
+                             ;; for sorting by DIRECTION, put it at the end.
+                             (a t)))
+             :key accessor)))
 
 ;;;; API
 
@@ -1038,30 +1041,6 @@ Prompts with PROMPT and DEFAULT, according to 
`format-prompt'.
 DEFAULT and INITIAL-INPUT are passed to `read-string' as-is."
   (read-string (format-prompt prompt default) initial-input 
'hyperdrive--name-history default))
 
-(defun hyperdrive-complete-sort ()
-  "Return a value for `hyperdrive-directory-sort' selected with completion."
-  (pcase-let* ((fn (pcase-lambda (`(cons :tag ,tag (const :format "" ,accessor)
-                                         (choice :tag "Direction" :value 
,_default-direction
-                                                 (const :tag "Ascending" 
,ascending-predicate)
-                                                 (const :tag "Descending" 
,descending-predicate))))
-                     (list tag accessor ascending-predicate 
descending-predicate)))
-               (columns (mapcar fn (cdr (get 'hyperdrive-directory-sort 
'custom-type))))
-               (read-answer-short t)
-               (choices (cl-loop for (tag . _) in columns
-                                 for name = (substring tag 3)
-                                 for key = (aref name 0)
-                                 collect (cons name (list key tag))))
-               (column-choice (read-answer "Sort by column: " choices))
-               (`(,accessor ,ascending-predicate ,descending-predicate)
-                (alist-get (concat "By " column-choice) columns nil nil 
#'equal))
-               (direction-choice (read-answer "Sort in direction: "
-                                              (list (cons "ascending" (list ?a 
"Ascending"))
-                                                    (cons "descending" (list 
?d "Descending")))))
-               (predicate (pcase direction-choice
-                            ("ascending" ascending-predicate)
-                            ("descending" descending-predicate))))
-    (cons accessor predicate)))
-
 (cl-defun hyperdrive-put-metadata (hyperdrive &key then)
   "Put HYPERDRIVE's metadata into the appropriate file, then call THEN."
   (declare (indent defun))
@@ -1314,6 +1293,12 @@ When BASE is non-nil, PATH will be expanded against BASE 
instead."
     (url-default-expander urlobj defobj)
     (url-recreate-url urlobj)))
 
+;;;; Utilities
+
+(defun hyperdrive-time-greater-p (a b)
+  "Return non-nil if time value A is greater than B."
+  (not (time-less-p a b)))
+
 (defun hyperdrive--clean-buffer (&optional buffer)
   "Remove all local variables, overlays, and text properties in BUFFER.
  When BUFFER is nil, act on current buffer."
diff --git a/hyperdrive-vars.el b/hyperdrive-vars.el
index e51cf6616a..4cf376c1ef 100644
--- a/hyperdrive-vars.el
+++ b/hyperdrive-vars.el
@@ -70,20 +70,19 @@
 Defaults to `eww-download-directory'."
   :type '(file :must-match t))
 
-(defvar hyperdrive-timestamp-format-string)
+(defvar hyperdrive-timestamp-width)
 (defcustom hyperdrive-timestamp-format "%x %X"
   "Format string used for timestamps.
 Passed to `format-time-string', which see."
   :type 'string
   :set (lambda (option value)
          (set-default option value)
-         (setf hyperdrive-timestamp-format-string
-               (format "%%%ds"
-                       ;; FIXME: This value varies based on current
-                       ;;        time. (format-time-string "%-I") will
-                       ;;        be one or two characters long
-                       ;;        depending on the time of day
-                       (string-width (format-time-string value))))))
+         (setf hyperdrive-timestamp-width
+               ;; FIXME: This value varies based on current
+               ;;        time. (format-time-string "%-I") will
+               ;;        be one or two characters long
+               ;;        depending on the time of day
+               (string-width (format-time-string value)))))
 
 (defcustom hyperdrive-directory-display-buffer-action
   '(display-buffer-same-window)
@@ -94,26 +93,24 @@ Passed to `display-buffer', which see."
                  (const :tag "Pop up window" (display-buffer-pop-up-window))
                  (sexp :tag "Other")))
 
-(defcustom hyperdrive-directory-sort '(hyperdrive-entry-name . string<)
+(defcustom hyperdrive-directory-sort '(name . :ascending)
   "Column by which directory entries are sorted.
-Internally, a cons cell of (KEY . PREDICATE), the KEY being the
-`hyperdrive-entry' accessor function and the PREDICATE being the
-appropriate function (e.g. `time-less-p' for
-`hyperdrive-entry-mtime', `<' for `hyperdrive-entry-size',
-etc)."
-  :type '(radio (cons :tag "By name" (const :format "" hyperdrive-entry-name)
-                      (choice :tag "Direction" :value string<
-                              (const :tag "Ascending" string<)
-                              (const :tag "Descending" string>)))
-                (cons :tag "By size" (const :format "" hyperdrive-entry-size)
-                      (choice :tag "Direction" :value <
-                              (const :tag "Ascending" <)
-                              (const :tag "Descending" >)))
-                (cons :tag "By date" (const :format "" hyperdrive-entry-mtime)
-                      (choice :tag "Direction" :value time-less-p
-                              (const :tag "Ascending" time-less-p)
-                              (const :tag "Descending" (lambda (a b)
-                                                         (not (time-less-p a 
b))))))))
+Internally, a cons cell of (COLUMN . DIRECTION), the COLUMN being
+one of the directory listing columns (\\+`name', \\+`size', or
+\\+`mtime') and DIRECTION being one of \\+`:ascending' or
+\\+`:descending'."
+  :type '(radio (cons :tag "By name" (const :format "" name)
+                      (choice :tag "Direction" :value :ascending
+                              (const :tag "Ascending" :ascending)
+                              (const :tag "Descending" :descending)))
+                (cons :tag "By size" (const :format "" size)
+                      (choice :tag "Direction" :value :ascending
+                              (const :tag "Ascending" :ascending)
+                              (const :tag "Descending" :descending)))
+                (cons :tag "By date" (const :format "" mtime)
+                      (choice :tag "Direction" :value :ascending
+                              (const :tag "Ascending" :ascending)
+                              (const :tag "Descending" :descending)))))
 
 (defcustom hyperdrive-history-display-buffer-action
   '(display-buffer-same-window)
@@ -191,7 +188,11 @@ an existing buffer at the same version, or make a new 
buffer."
   "Directory path.")
 
 (defface hyperdrive-column-header '((t (:inherit underline)))
-  "Directory path.")
+  "Column header.")
+
+(defface hyperdrive-selected-column-header '((t ( :inherit underline
+                                                  :weight bold)))
+  "Selected column header.")
 
 (defface hyperdrive-directory '((t (:inherit dired-directory)))
   "Subdirectories.")
@@ -202,6 +203,9 @@ an existing buffer at the same version, or make a new 
buffer."
 (defface hyperdrive-timestamp '((t (:inherit default)))
   "Entry timestamp.")
 
+(defface hyperdrive-header-arrow '((t (:inherit bold)))
+  "Header arrows.")
+
 (defface hyperdrive-history-range '((t (:inherit font-lock-escape-face)))
   "Version range in `hyperdrive-history' buffers.")
 
@@ -291,6 +295,21 @@ values are alists mapping version range starts to plists 
with
   "Alist mapping MIME types to handler functions.
 Keys are regexps matched against MIME types.")
 
+(defvar hyperdrive-dir-sort-fields
+  '((size  :accessor hyperdrive-entry-size
+           :ascending <
+           :descending >
+           :desc "Size")
+    (mtime :accessor hyperdrive-entry-mtime
+           :ascending time-less-p
+           :descending hyperdrive-time-greater-p
+           :desc "Last Modified")
+    (name  :accessor hyperdrive-entry-name
+           :ascending string<
+           :descending string>
+           :desc "Name"))
+  "Fields for sorting hyperdrive directory buffer columns.")
+
 ;;;; Footer
 
 (provide 'hyperdrive-vars)
diff --git a/hyperdrive.el b/hyperdrive.el
index 8422bbf013..b784a9a998 100644
--- a/hyperdrive.el
+++ b/hyperdrive.el
@@ -710,6 +710,8 @@ Universal prefix argument \\[universal-argument] forces
 
 ;;;; Configure Emacs and EWW for hyper:// URLs.
 
+(require 'url)
+
 (defun hyperdrive-url-loader (parsed-url)
   "Retrieve URL synchronously.
 PARSED-URL must be a URL-struct like the output of