Ihor Radchenko <[email protected]> writes:
> Maybe some menus can say :menu-systems '(transient) to force using
> transient even when other menu-backend is specified by user. That option
> might be exposed to users. Then, we can easily incorporate
> transient-only menus or even menus that employ a completely custom menu
> implementation. It feels like an easy generalization that does not
> require too much effort.
>
I did a very simple implementation of this, which allows specifying
precisely one forced menu system, or also a variable where the menu
system could be set (e.g. org-menu-system as default).
>>>This can probably be a separate new function instead of adding inline lambda.
>>
>> I added this as org-cite-basic--browse.
>
> I think it would be better if `org-cite-basic--browse' used its
> argument rather than referring to !citation-object :)
> Also, the function does not work in general because of stray comment (";").
>
Ouch, thanks for being awake :-)
>>>> +(defun org-menu--specification-to-menu (description specification)
>>> ...
>>>This looks like tail recursion. Any chance you can write the same using
>>>some kind of loop/mapcar? (I admit that I do not 100% understand the logic)
>>
>> We need to achieve two things:
>> All entries (including titles and separators) in the keymap need unique keys.
>> Entries must be added in reverse to the keymap.
>> ...
>
> I came up with the following version
>
> (defun org-menu--specification-to-menu (description specification)
> "Make a flattened menu keymap out of an org menu specification.
>
> SPECIFICATION should be of the form of `org-cite-basic-follow-actions'.
>
> The title of the menu keymap is DESCRIPTION."
> (let ((new-map (make-sparse-keymap description))
> (prev-item-was-header nil))
> (letrec ((define-menu
> (lambda (menu)
> (seq-map
> (lambda (item)
> (message "%S" item)
> (when prev-item-was-header
> ;; Add separator in all but last header.
> (setq prev-item-was-header nil)
> (define-key new-map `[,(gensym "separator-")]
> '(menu-item "--")))
> (pcase item
> ((pred vectorp) (funcall define-menu item))
> ((pred stringp)
> ;; FIXME: Use `keymap-set' when we drop Emacs 28
> support.
> (define-key new-map `[,(gensym "header-")] `(menu-item
> ,item))
> (setq prev-item-was-header t))
> (`(,key ,desc ,function)
> (define-key new-map key `(menu-item ,desc ,function)))))
> (seq-reverse menu)))))
> (funcall define-menu specification)
> new-map)))
>
That is better, thanks:-)
> Hmm. What about replacing :contents with :menu?
Sure, maybe even menu-contents, but lets go with menu.
> Also, :interactive-spec seems misleading. It is basically function body.
> What about defining it as &body? It feels intuitive.
>
I'm feeling stupid about this - I have an unreasonably difficult time
getting &key and &body to play well, so I chickened out and just renamed
the interactive-spec keyword to body.
Otherwise, does this start to be in such a shape that I should write
the NEWS entry?
Cheers
>From 4486b79b5a19062ad1d850ab90056897827130d9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Tor-bj=C3=B6ron?= <[email protected]>
Date: Thu, 27 Feb 2025 20:30:07 +0200
Subject: [PATCH] lisp/om.el: Org-menu, a simple menu system for org.
* lisp/om.el: Add org-menu.
* lisp/oc-basic.el (require 'om): Pull in om.
(org-cite-basic-follow-actions): New customization option, that
specifies the contents of the transient menu.
(org-cite-basic-follow-default-action): New customization option,
the default action to be taken when following a citation object.
(org-cite-basic--get-key): New function. Get citation key from
citation or citation reference.
(org-cite-basic--get-url): New function. Get URL from citation or
citation reference.
(org-cite-basic--get-doi): New function. Get DOI from citation or
citation reference.
(org-cite-basic--browse): New function. Browse (using browse-url)
the URL or DOI-based URL of a citation or citation reference.
(org-cite-basic-goto): Use org-cite-basic--get-key.
(org-cite-basic-follow): Add a citation follower using org-menu.
(org-cite-register-processor 'basic): Update the basic citation
processor to follow citations using `org-cite-basic-follow'.
This change was co-authored with much support from Ihor Radchenko and
Jonas Bernoulli, thanks!
---
lisp/oc-basic.el | 75 +++++++++--
lisp/om.el | 315 +++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 381 insertions(+), 9 deletions(-)
create mode 100644 lisp/om.el
diff --git a/lisp/oc-basic.el b/lisp/oc-basic.el
index fb6d9477a..b1a922e07 100644
--- a/lisp/oc-basic.el
+++ b/lisp/oc-basic.el
@@ -74,10 +74,12 @@
(require 'map)
(require 'oc)
(require 'seq)
+(require 'om)
(declare-function org-open-at-point "org" (&optional arg))
(declare-function org-open-file "org" (path &optional in-emacs line search))
+(declare-function org-element-context "org-element" (&optional element))
(declare-function org-element-create "org-element-ast" (type &optional props &rest children))
(declare-function org-element-set "org-element-ast" (old new &optional keep-props))
@@ -351,6 +353,41 @@ INFO is the export state, as a property list."
(map-keys entries))
(org-cite-basic--parse-bibliography)))
+(defun org-cite-basic--get-key (citation-or-citation-reference)
+ "Return citation key for CITATION-OR-CITATION-REFERENCE."
+ (if (org-element-type-p citation-or-citation-reference 'citation-reference)
+ (org-element-property :key citation-or-citation-reference)
+ (pcase (org-cite-get-references citation-or-citation-reference t)
+ (`(,key) key)
+ (keys
+ (or (completing-read "Select citation key: " keys nil t)
+ (user-error "Aborted"))))))
+
+(defun org-cite-basic--get-url (citation-or-citation-reference)
+ "Return URL for CITATION-OR-CITATION-REFERENCE."
+ (org-cite-basic--get-field
+ 'url
+ (org-cite-basic--get-key citation-or-citation-reference)))
+
+(defun org-cite-basic--get-doi (citation-or-citation-reference)
+ "Return DOI for CITATION-OR-CITATION-REFERENCE."
+ (org-cite-basic--get-field
+ 'doi
+ (org-cite-basic--get-key citation-or-citation-reference)))
+
+(defun org-cite-basic--browse (citation-or-citation-reference)
+ "Browse (using `browse-url') to the URL or DOI of CITATION-OR-CITATION-REFERENCE."
+ (let ((url (org-cite-basic--get-url citation-or-citation-reference))
+ (doi (org-cite-basic--get-doi citation-or-citation-reference)))
+ (cond ((org-string-nw-p url)
+ (browse-url url))
+ ((org-string-nw-p doi)
+ (if (string-match "^http" doi)
+ (browse-url doi)
+ (browse-url (format "http://dx.doi.org/%s"; doi))))
+ (t (user-error "No URL or DOI for `%s'"
+ (org-cite-basic--get-key citation-or-citation-reference))))))
+
(defun org-cite-basic--get-entry (key &optional info)
"Return BibTeX entry for KEY, as an association list.
When non-nil, INFO is the export state, as a property list."
@@ -830,14 +867,7 @@ export state, as a property list."
When DATUM is a citation reference, open bibliography entry referencing
the citation key. Otherwise, select which key to follow among all keys
present in the citation."
- (let* ((key
- (if (org-element-type-p datum 'citation-reference)
- (org-element-property :key datum)
- (pcase (org-cite-get-references datum t)
- (`(,key) key)
- (keys
- (or (completing-read "Select citation key: " keys nil t)
- (user-error "Aborted"))))))
+ (let* ((key (org-cite-basic--get-key datum))
(file
(pcase (seq-find (pcase-lambda (`(,_ . ,entries))
(gethash key entries))
@@ -857,6 +887,33 @@ present in the citation."
(bibtex-set-dialect)
(bibtex-search-entry key)))))
+(org-menu-define org-cite-basic-follow (citation-object &optional prefix-argument)
+ "Follow citation
+
+Open citations by applying the function in
+`org-cite-basic-follow-default-action'. "
+ :menu [["Open"
+ ("b" "Bibliography entry" (org-cite-basic-goto !citation-object !prefix-argument))
+ ("w" "Browse URL/DOI"
+ (org-cite-basic--browse !citation-object))]
+ ["Copy"
+ ("d" "DOI"
+ (let ((doi (org-cite-basic--get-doi !citation-object)))
+ (if (org-string-nw-p doi)
+ (kill-new doi)
+ (user-error "No DOI for `%s'" (org-cite-basic--get-key !citation-object)))))
+ ("u" "URL"
+ (let ((url (org-cite-basic--get-url !citation-object)))
+ (if (org-string-nw-p url)
+ (kill-new url)
+ (user-error "No URL for `%s'" (org-cite-basic--get-key !citation-object)))))]]
+ :default-action (org-cite-basic-goto !citation-object !prefix-argument)
+ :body (interactive
+ (list (let ((obj (org-element-context)))
+ (pcase (org-element-type obj)
+ ((or 'citation 'citation-reference) obj)
+ (_ (user-error "Wrong object type")))))))
+
;;; "Insert" capability
(defun org-cite-basic--complete-style (_)
@@ -1006,7 +1063,7 @@ Raise an error when no bibliography is set in the buffer."
:activate #'org-cite-basic-activate
:export-citation #'org-cite-basic-export-citation
:export-bibliography #'org-cite-basic-export-bibliography
- :follow #'org-cite-basic-goto
+ :follow #'org-cite-basic-follow
:insert (org-cite-make-insert-processor #'org-cite-basic--complete-key
#'org-cite-basic--complete-style)
:cite-styles
diff --git a/lisp/om.el b/lisp/om.el
new file mode 100644
index 000000000..195686022
--- /dev/null
+++ b/lisp/om.el
@@ -0,0 +1,315 @@
+;;; om.el --- Org Menu library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2025 Free Software Foundation, Inc.
+
+;; Author: Tor-björn Claesson <[email protected]>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides facilities for displaying menus in org mode.
+
+;;; Code:
+
+(require 'cl-macs)
+(require 'org-macs)
+(require 'transient)
+(require 'which-key)
+
+(org-assert-version)
+
+
+;;; Configuration variables
+(defgroup org-menu nil
+ "Options concerning menus in Org mode."
+ :group 'org
+ :tag "Org Menu")
+
+(defcustom org-menu-switch '-
+ "Prefix argument that inverts the behaviour of `org-menu-mode'."
+ :group 'org-menu
+ :package-version '(Org . "9.8")
+ :type 'sexp)
+
+(defcustom org-menu-system 'transient
+ "The menu system to use for displaying Org Menus.
+
+Unless equal to transient, it should be a function with the
+signature (specification), where SPECIFICATION is a menu definition as per
+`org-cite-basic-follow-actions'.
+
+org-menu includes the functions `org-menu-popup' and `org-menu-tmm-prompt',
+which are valid options for `org-menu-system'."
+ :group 'org-menu
+ :package-version '(Org . "9.8")
+ :type 'sexp)
+
+
+;;; Minor mode
+(define-minor-mode org-menu-mode
+ "Org menu mode.
+When Org menu mode is enabled, a menu prompting the user for an action
+will be presented upon activating certain objects.
+
+New menus can be defined using `org-menu-define'.
+
+The menu system used can be customized in `org-menu-system'.
+
+When `org-menu-mode' is active, it can be transiently deactivated by
+the prefix argument specified in `org-menu-switch', and vice verse
+transiently activated when inactive."
+ :init-value nil
+ :lighter " OM")
+
+;;; Helper functions
+
+(defmacro org-menu--bind-specification (bindings specification)
+ "Make BINDINGS visible to commands in SPECIFICATION.
+
+BINDINGS is a list of the form ((binding value) ...).
+SPECIFICATION is an org menu as per `org-cite-basic-follow-actions'.
+
+This macro returns SPECIFICATION, with each action wrapped in
+a let exposing BINDINGS."
+ `(cl-map
+ 'vector
+ (lambda (group)
+ (cl-map
+ 'vector
+ (lambda (spec)
+ (pcase spec
+ (`(,key ,desc (lambda ,args . ,body) . ,other)
+ `(,key ,desc
+ (lambda ,args
+ ,(unless (and (listp (car body))
+ (equal (caar body)
+ 'interactive))
+ '(interactive))
+ (let ,,bindings
+ ,@body))
+ ,@other))
+ (`(,key ,desc (,fn . ,fn-args) . ,other)
+ `(,key ,desc
+ (lambda ()
+ (interactive)
+ (let ,,bindings
+ (,fn ,@fn-args)))
+ ,@other))
+ (other other)))
+ group))
+ ,specification))
+
+(cl-defmacro org-menu--with-arguments (arg-list &body body)
+ "Make the arguments in ARG-LIST, prefixed with !, visible to BODY."
+ `(dlet ,(mapcar (lambda (arg)
+ `(,(intern (concat "!" (symbol-name arg))) ,arg))
+ arg-list)
+ ,@body))
+
+(defun org-menu--specification-to-menu (description specification)
+ "Make a flattened menu keymap out of an org menu specification.
+SPECIFICATION should be of the form of `org-cite-basic-follow-actions'.
+The title of the menu keymap is DESCRIPTION."
+ (let ((new-map (make-sparse-keymap description))
+ (prev-item-was-header nil))
+ (letrec ((define-menu
+ (lambda (menu)
+ (seq-map
+ (lambda (item)
+ (message "%S" item)
+ (when prev-item-was-header
+ ;; Add separator in all but last header.
+ (setq prev-item-was-header nil)
+ (define-key new-map `[,(gensym "separator-")] '(menu-item "--")))
+ (pcase item
+ ((pred vectorp) (funcall define-menu item))
+ ((pred stringp)
+ ;; FIXME: Use `keymap-set' when we drop Emacs 28 support.
+ (define-key new-map `[,(gensym "header-")] `(menu-item ,item))
+ (setq prev-item-was-header t))
+ (`(,key ,desc ,function)
+ (define-key new-map key `(menu-item ,desc ,function)))))
+ (seq-reverse menu)))))
+ (funcall define-menu specification)
+ new-map)))
+
+(defun org-menu-popup (description specification)
+ "Show an org-menu using a `popup-menu'.
+
+This function is a valid value for `org-menu-system':
+DESCRIPTION is the title for the menu, while SPECIFICATION is an org-menu
+specification as per `org-cite-basic-follow-actions'."
+ (let ((menu-keymap (org-menu--specification-to-menu description specification)))
+ (popup-menu menu-keymap)))
+
+(defun org-menu-tmm-prompt (description specification)
+ "Show an org-menu using a `tmm-prompt'.
+
+This function is a valid value for `org-menu-system':
+DESCRIPTION is the title for the menu, while SPECIFICATION is an org-menu
+specification as per `org-cite-basic-follow-actions'."
+ (let ((menu-keymap (org-menu--specification-to-menu description specification)))
+ (tmm-prompt menu-keymap)))
+
+
+(defmacro org-menu--defcustom-actions (menu-actions value menu-name)
+ "Define MENU-ACTIONS option for MENU-NAME with default VALUE."
+ `(progn (defcustom ,menu-actions ,value
+ ,(concat "Actions in the `" (symbol-name menu-name) "' org menu.
+
+This option uses the same syntax as `transient-define-prefix', see
+Info node `(transient)Binding Suffix and Infix Commands'. In
+addition, it is possible to specify a function call for the COMMAND
+part, where ARGUMENTS can be used to access those values.
+
+For example:
+
+[[\"Open\"
+ (\"b\" \"bibliography entry\"
+ (org-cite-basic-goto !citation-object !prefix-argument))]]
+
+will create an entry labeled \"bibliography entry\", activated with the
+b key, that calls `org-cite-basic-goto' with citation-object and
+prefix-argument as arguments.")
+ :group 'org-menu
+ :type 'sexp)
+ (put ',menu-actions 'definition-name ',menu-name)))
+
+(defmacro org-menu--defcustom-default-action
+ (default-action value menu-name arglist)
+ "Define DEFAULT-ACTION option for MENU-NAME with default VALUE.
+The action will accept ARGLIST arguments."
+ `(progn (defcustom ,default-action ,value
+ ,(concat "Default action for `" (symbol-name menu-name) "'.
+This should be a function accepting the arguments\n\="
+ (prin1-to-string arglist)
+ ".")
+ :group 'org-menu
+ :type 'sexp)
+ (put ',default-action 'definition-name ',menu-name)))
+
+(defun org-menu--strip-argument-decorators (arglist)
+ "Return a copy of ARGLIST without &optional or &rest."
+ (seq-filter
+ (lambda (elt)
+ (not (or (eq elt '&optional)
+ (eq elt '&rest))))
+ arglist))
+
+;;; Main macro definition
+(cl-defmacro org-menu-define
+ (name arglist docstring &key menu default-action (menu-system 'org-menu-system) (body '(interactive)))
+ "Define an org menu NAME.
+
+A function called NAME will be created to activate the menu, as well as
+variables called NAME-actions and NAME-default-action.
+
+ARGLIST is the argument list of the function NAME.
+
+DOCSTRING is the docstring for NAME. The first row is used as title for
+keymaps based on this menu. The rest of the DOCSTRING should describe what
+the default action does. A short description of `org-menu-mode' and the
+customization containing the menu definition will be appended.
+
+Following this, the function accepts the following keyword arguments:
+
+MENU is used to populate the NAME-actions variable. It follows the syntax
+decribed in `(transient)Binding Suffix and Infix Commands',
+with the addition that the arguments in ARGLIST are accessible
+prefixed with !. For an example, see `org-cite-basic-follow-actions'.
+
+DEFAULT-ACTION specifies the action to be taken, if org-menu is
+inactive (as determined by `org-menu-mode' and modified by a
+prefix argument set in `org-menu-switch'.
+It has the form of a function call, where the arguments in
+ARGLIST are accessible prefixed by !. For example, the default action
+of `org-cite-basic-follow', which is defined with n ARGLIST
+\\(citation-object prefix-argument), has the form
+\\(org-cite-basic-goto !citation-object !prefix-argument).
+
+MENU-SYSTEM forces the use of a specific menu backend. Some examples of valid
+values for this parameter are \='transient or #\='org-menu-popup.
+
+BODY is optional and can be used to set up the interactive
+environment and validate arguments. The body will be evaluated on activation
+of the menu, also when the default action is called."
+ (declare (indent defun))
+ (let ((menu-default-action
+ (intern (concat (symbol-name name) "-default-action")))
+ (menu-actions
+ (intern (concat (symbol-name name) "-actions"))))
+ `(progn
+ (org-menu--defcustom-actions
+ ,menu-actions ',menu ,name)
+ (org-menu--defcustom-default-action
+ ,menu-default-action
+ ',default-action
+ ,name
+ ',arglist)
+ (transient-define-prefix
+ ,name ,arglist
+ ,(concat docstring
+ "
+
+If `org-menu-mode' is active, display the menu specified in
+`"
+ (symbol-name menu-actions)
+ "'.
+
+This behaviour can be inverted by giving the prefix argument in
+`org-menu-switch'. See `org-menu-mode' for more information.")
+ [:class
+ transient-columns
+ :setup-children
+ (lambda (_)
+ (transient-parse-suffixes
+ ',name
+ (org-menu--bind-specification
+ (transient-scope)
+ ,menu-actions)))
+ :pad-keys t]
+ ,body
+ (let ((bound-arguments
+ (list ,@(mapcar
+ (lambda (param)
+ `(list
+ ',(intern (concat "!" (symbol-name param)))
+ `',,param))
+ (org-menu--strip-argument-decorators arglist)))))
+ ;; Should we display a menu? If so, how?
+ (cond ((not (xor org-menu-mode
+ (eq current-prefix-arg org-menu-switch)))
+ ;; Call the default action
+ (org-menu--with-arguments
+ ,(org-menu--strip-argument-decorators arglist)
+ (eval ,menu-default-action)))
+ ((eq ,menu-system 'transient)
+ ;; Activate transient
+ (transient-setup
+ (quote ,name) nil nil
+ :scope bound-arguments))
+ (t
+ ;; Use the system specified in `org-menu-system'
+ (funcall
+ ,menu-system
+ ,(car (split-string docstring "[\n]"))
+ (org-menu--bind-specification
+ bound-arguments
+ ,menu-actions)))))))))
+
+(provide 'om)
+;;; om.el ends here
--
2.47.3
