branch: elpa/hyperdrive
commit ff71f006dcbe3d8bc8f729764159ef8804470d37
Author: Joseph Turner <jos...@ushin.org>
Commit: Joseph Turner <jos...@ushin.org>
Change: (-directory-sort) Use :ascending and :descending keywords
This change consolidates the definitions of sorting predicates, and
hopefully improves readability.
---
hyperdrive-dir.el | 33 +++++++++++++--------------------
hyperdrive-lib.el | 50 +++++++++++++++++++++++---------------------------
hyperdrive-vars.el | 27 ++++++++++++++++-----------
3 files changed, 52 insertions(+), 58 deletions(-)
diff --git a/hyperdrive-dir.el b/hyperdrive-dir.el
index 840597f83e..150b989fc3 100644
--- a/hyperdrive-dir.el
+++ b/hyperdrive-dir.el
@@ -120,29 +120,22 @@ 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) "▼")))))
+ (pcase-let* ((`(,accessor . ,direction) hyperdrive-directory-sort)
+ (arrow (if (eq direction :ascending) "▲" "▼"))
+ (size-header (propertize "Size" 'face
'hyperdrive-column-header))
+ (mtime-header (propertize "Last Modified" 'face
'hyperdrive-column-header))
+ (name-header (propertize "Name" 'face
'hyperdrive-column-header)))
+ (pcase-exhaustive accessor
+ ('hyperdrive-entry-size (cl-callf2 concat arrow size-header))
+ ('hyperdrive-entry-mtime (cl-callf2 concat arrow mtime-header))
+ ;; Put the arrow second so that the header doesn't move.
+ ('hyperdrive-entry-name (cl-callf concat name-header arrow)))
(concat prefix "\n"
(format "%6s %s %s"
- (concat size-arrow
- (propertize "Size" 'face
'hyperdrive-column-header))
+ size-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)))))
+ mtime-header)
+ name-header))))
(defun hyperdrive-dir-pp (thing)
"Pretty-print THING.
diff --git a/hyperdrive-lib.el b/hyperdrive-lib.el
index 211e8f1cb0..b805c79bc8 100644
--- a/hyperdrive-lib.el
+++ b/hyperdrive-lib.el
@@ -131,12 +131,14 @@ generated from PATH. When ENCODE is non-nil, encode
PATH."
(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)))
+ (pcase-let* ((`(,accessor . ,direction) by)
+ ((map (direction sort-function)) (alist-get accessor
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 with BY, put it at the end.
+ (a t)))
+ :key accessor)))
;;;; API
@@ -1034,27 +1036,21 @@ DEFAULT and INITIAL-INPUT are passed to `read-string'
as-is."
(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)))
+ (pcase-let* ((read-answer-short t)
+ (choices (mapcar (pcase-lambda (`(,_accessor . ,(map (:desc
desc))))
+ (list desc (aref desc 0) (format "Sort by
%s" desc)))
+ hyperdrive-dir-sort-fields))
+ (desc (read-answer "Sort by column: " choices))
+ (`(,accessor . ,(map (:ascending _ascending) (:descending
_descending)))
+ (cl-rassoc desc hyperdrive-dir-sort-fields
+ :test (lambda (desc fields-properties)
+ (equal desc (map-elt fields-properties
:desc)))))
+ (`(,current-accessor . ,current-direction)
hyperdrive-directory-sort)
+ (direction (if (and (eq accessor current-accessor)
+ (eq current-direction :ascending))
+ :descending
+ :ascending)))
+ (cons accessor direction)))
(cl-defun hyperdrive-put-metadata (hyperdrive &key then)
"Put HYPERDRIVE's metadata into the appropriate file, then call THEN."
diff --git a/hyperdrive-vars.el b/hyperdrive-vars.el
index e51cf6616a..23256b4f12 100644
--- a/hyperdrive-vars.el
+++ b/hyperdrive-vars.el
@@ -94,7 +94,7 @@ 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 '(hyperdrive-entry-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
@@ -102,18 +102,17 @@ 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>)))
+ (choice :tag "Direction" :value :ascending
+ (const :tag "Ascending" :ascending)
+ (const :tag "Descending" :descending)))
(cons :tag "By size" (const :format "" hyperdrive-entry-size)
- (choice :tag "Direction" :value <
- (const :tag "Ascending" <)
- (const :tag "Descending" >)))
+ (choice :tag "Direction" :value :ascending
+ (const :tag "Ascending" :ascending)
+ (const :tag "Descending" :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))))))))
+ (choice :tag "Direction" :value :ascending
+ (const :tag "Ascending" :ascending)
+ (const :tag "Descending" :descending)))))
(defcustom hyperdrive-history-display-buffer-action
'(display-buffer-same-window)
@@ -291,6 +290,12 @@ 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
+ '((hyperdrive-entry-name :desc "name" :ascending string< :descending
string>)
+ (hyperdrive-entry-size :desc "size" :ascending < :descending >)
+ (hyperdrive-entry-mtime :desc "mtime" :ascending time-less-p :descending
hyperdrive-time-greater-p))
+ "Fields for sorting hyperdrive directory buffer columns.")
+
;;;; Footer
(provide 'hyperdrive-vars)
