[PATCH] org-sort: Read compare-func in interactive calls

[Kyle Meyer <kyle@kyleam.com>]

* lisp/org-macs.el (org-read-function): New function.
* lisp/org.el (org-sort-entries):
* lisp/org-table.el (org-table-sort-lines):
* lisp/org-list.el (org-sort-list): Read COMPARE-FUNC when called
interactively rather than being restricted to the default behavior of
sort-subr's PREDICATE parameter.  Guard prompts for GETKEY-FUNC and
COMPARE-FUNCTION with called-interactively-p, like
org-table-sort-lines already did for GETKEY-FUNC.

Suggested-by: Zhitao Gong <zhitaao.gong@gmail.com>
<https://lists.gnu.org/archive/html/emacs-orgmode/2017-05/msg00040.html>
---
 lisp/org-list.el  | 35 +++++++++++++++++++++--------------
 lisp/org-macs.el  | 10 ++++++++++
 lisp/org-table.el | 20 +++++++++++---------
 lisp/org.el       | 44 ++++++++++++++++++++++++++------------------
 4 files changed, 68 insertions(+), 41 deletions(-)

diff --git a/lisp/org-list.el b/lisp/org-list.el
index b49bff8b9..17ff5d160 100644
--- a/lisp/org-list.el
+++ b/lisp/org-list.el
@@ -2863,9 +2863,8 @@ (defun org-sort-list (&optional with-case sorting-type getkey-func compare-func)
 
 If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies
 a function to be called with point at the beginning of the
-record.  It must return either a string or a number that should
-serve as the sorting key for that record.  It will then use
-COMPARE-FUNC to compare entries.
+record.  It must return a value that is compatible with COMPARE-FUNC,
+the function used to compare entries.
 
 Sorting is done against the visible part of the headlines, it
 ignores hidden links."
@@ -2881,23 +2880,31 @@ (defun org-sort-list (&optional with-case sorting-type getkey-func compare-func)
 		(message
 		 "Sort plain list: [a]lpha  [n]umeric  [t]ime  [f]unc  [x]checked  A/N/T/F/X means reversed:")
 		(read-char-exclusive))))
+	 (dcst (downcase sorting-type))
 	 (getkey-func
-	  (or getkey-func
-	      (and (= (downcase sorting-type) ?f)
-		   (intern (completing-read "Sort using function: "
-					    obarray 'fboundp t nil nil))))))
+	  (and (= dcst ?f)
+	       (or getkey-func
+		   (and (called-interactively-p 'any)
+			(org-read-function "Function for extracting keys: "))
+		   (error "Missing key extractor"))))
+	 (sort-func
+	  (cond
+	   ((= dcst ?a) #'string<)
+	   ((= dcst ?f)
+	    (or compare-func
+		(and (called-interactively-p 'any)
+		     (org-read-function
+		      (concat "Function for comparing keys"
+			      "(empty for default `sort-subr' predicate): ")
+		      'allow-empty))))
+	   ((= dcst ?t) #'<)
+	   ((= dcst ?x) #'string<))))
     (message "Sorting items...")
     (save-restriction
       (narrow-to-region start end)
       (goto-char (point-min))
-      (let* ((dcst (downcase sorting-type))
-	     (case-fold-search nil)
+      (let* ((case-fold-search nil)
 	     (now (current-time))
-	     (sort-func (cond
-			 ((= dcst ?a) 'string<)
-			 ((= dcst ?f) compare-func)
-			 ((= dcst ?t) '<)
-			 ((= dcst ?x) 'string<)))
 	     (next-record (lambda ()
 			    (skip-chars-forward " \r\t\n")
 			    (or (eobp) (beginning-of-line))))
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index e4b39a2c2..ca47e5a5a 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -294,6 +294,16 @@ (defun org-unbracket-string (pre post string)
       (substring string (length pre) (- (length post)))
     string))
 
+(defun org-read-function (prompt &optional allow-empty?)
+  "Prompt for a function.
+If ALLOW-EMPTY? is non-nil, return nil rather than raising an
+error when the user input is empty."
+  (let ((func (completing-read prompt obarray #'fboundp t)))
+    (cond ((not (string= func ""))
+	   (intern func))
+	  (allow-empty? nil)
+	  (t (user-error "Empty input is not valid")))))
+
 (provide 'org-macs)
 
 ;;; org-macs.el ends here
diff --git a/lisp/org-table.el b/lisp/org-table.el
index 84e2b4d4e..d37edbe83 100644
--- a/lisp/org-table.el
+++ b/lisp/org-table.el
@@ -1671,11 +1671,9 @@ (defun org-table-sort-lines (with-case &optional sorting-type getkey-func compar
 sorting should be done in reverse order.
 
 If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies
-a function to be called to extract the key.  It must return either
-a string or a number that should serve as the sorting key for that
-row.  It will then use COMPARE-FUNC to compare entries.  If GETKEY-FUNC
-is specified interactively, the comparison will be either a string or
-numeric compare based on the type of the first key in the table."
+a function to be called to extract the key.  It must return a value
+that is compatible with COMPARE-FUNC, the function used to compare
+entries."
   (interactive "P")
   (when (org-region-active-p) (goto-char (region-beginning)))
   ;; Point must be either within a field or before a data line.
@@ -1735,16 +1733,20 @@ (defun org-table-sort-lines (with-case &optional sorting-type getkey-func compar
 		((?f ?F)
 		 (or getkey-func
 		     (and (called-interactively-p 'any)
-			  (intern
-			   (completing-read "Sort using function: "
-					    obarray #'fboundp t)))
+			  (org-read-function "Function for extracting keys: "))
 		     (error "Missing key extractor to sort rows")))
 		(t (user-error "Invalid sorting type `%c'" sorting-type))))
 	     (predicate
 	      (cl-case sorting-type
 		((?n ?N ?t ?T) #'<)
 		((?a ?A) #'string<)
-		((?f ?F) compare-func))))
+		((?f ?F)
+		 (or compare-func
+		     (and (called-interactively-p 'any)
+			  (org-read-function
+			   (concat "Fuction for comparing keys "
+				   "(empty for default `sort-subr' predicate): ")
+			   'allow-empty)))))))
 	(goto-char (point-min))
 	(sort-subr (memq sorting-type '(?A ?N ?T ?F))
 		   (lambda ()
diff --git a/lisp/org.el b/lisp/org.el
index 20f130478..251b19cb7 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -9120,8 +9120,9 @@ (defun org-sort-entries
 Capital letters will reverse the sort order.
 
 If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies a function to be
-called with point at the beginning of the record.  It must return either
-a string or a number that should serve as the sorting key for that record.
+called with point at the beginning of the record.  It must return a
+value that is compatible with COMPARE-FUNC, the function used to
+compare entries.
 
 Comparing entries ignores case by default.  However, with an optional argument
 WITH-CASE, the sorting considers case as well.
@@ -9199,21 +9200,22 @@ (defun org-sort-entries
                [t]ime [s]cheduled  [d]eadline  [c]reated  cloc[k]ing
                A/N/P/R/O/F/T/S/D/C/K means reversed:"
        what)
-      (setq sorting-type (read-char-exclusive))
-
-      (unless getkey-func
-	(and (= (downcase sorting-type) ?f)
-	     (setq getkey-func
-		   (completing-read "Sort using function: "
-				    obarray 'fboundp t nil nil))
-	     (setq getkey-func (intern getkey-func))))
-
-      (and (= (downcase sorting-type) ?r)
-	   (not property)
-           (setq property
-                 (completing-read "Property: "
-				  (mapcar #'list (org-buffer-property-keys t))
-				  nil t))))
+      (setq sorting-type (read-char-exclusive)))
+
+    (unless getkey-func
+      (and (= (downcase sorting-type) ?f)
+	   (setq getkey-func
+		 (or (and (called-interactively-p 'any)
+			  (org-read-function
+			   "Function for extracting keys: "))
+		     (error "Missing key extractor")))))
+
+    (and (= (downcase sorting-type) ?r)
+	 (not property)
+	 (setq property
+	       (completing-read "Property: "
+				(mapcar #'list (org-buffer-property-keys t))
+				nil t)))
 
     (when (member sorting-type '(?k ?K)) (org-clock-sum))
     (message "Sorting entries...")
@@ -9297,7 +9299,13 @@ (defun org-sort-entries
          nil
          (cond
           ((= dcst ?a) 'string<)
-          ((= dcst ?f) compare-func)
+          ((= dcst ?f)
+	   (or compare-func
+	       (and (called-interactively-p 'any)
+		    (org-read-function
+		     (concat "Function for comparing keys "
+			     "(empty for default `sort-subr' predicate): ")
+		     'allow-empty))))
           ((member dcst '(?p ?t ?s ?d ?c ?k)) '<)))))
     (run-hooks 'org-after-sorting-entries-or-items-hook)
     ;; Reset the clock marker if needed
-- 
2.12.2