branch: elpa/hyperdrive
commit fcda78fd069adebf961a099c881c5d0110c74c3a
Merge: 53927eb0a9 eaf2e5104f
Author: Adam Porter <a...@alphapapa.net>
Commit: Adam Porter <a...@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
