Ihor Radchenko <yanta...@posteo.net> writes:
> Since there will be a another update on the patch, I am just posting what
> I've done so far with this version.
> ,@(pcase body
> - (`((interactive . ,interactive-spec) . ,body)
> - `((interactive ,@interactive-spec) ,body))
> + (`((interactive . _) . _)
> + body)
> (_
> - `((interactive (list (org-element-context))) ,@body)))
> + `((interactive (list (org-element-context)))
> + ,@body)))
This doesn't always match the body, I redid it without pattern matching.
All other changes are applied, thanks!
I have attached a new version of the patch with a working prototype. We
now have a function org-menu-popup, which can be used for
org-menu-system. To support this we have org-menu--bind-specification
(which is also used for the transient) and
org-menu--specifications-to-menu, which builds a menu style keymap from
a transient specification.
My difficulty turned out to be that we have to delay the evaluation of
the let bound parameters value until after the binding (this already happened
for the transient, since we bound to a call to plist-get).
This is the most complicated thing I have written, and though I am happy
to have gotten this far, since I'm no programmer, I suspect there
is room for improvement, and have not yet spent much time on the
docstrings (org-cite-basic-follow stands out as needing one) or
NEWS. Once the design is finalised, I will be happy to do those:-)
Cheers,
Tor-björn
>From b1b7208f9e43e54d864581ed52ec6f28e2cee355 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Tor-bj=C3=B6ron?= <tclaes...@gmail.com>
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--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-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 | 69 ++++++++++--
lisp/om.el | 275 +++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 335 insertions(+), 9 deletions(-)
create mode 100644 lisp/om.el
diff --git a/lisp/oc-basic.el b/lisp/oc-basic.el
index e2b36c49a..54dfdacd1 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,28 @@ 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-KEY."
+ (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-KEY."
+ (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-KEY."
+ (org-cite-basic--get-field
+ 'doi
+ (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 +854,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 +874,40 @@ present in the citation."
(bibtex-set-dialect)
(bibtex-search-entry key)))))
+(org-menu-define org-cite-basic-follow (citation-object)
+ "Follow citations"
+ "Follow citation"
+ [["Open"
+ ("b" "bibliography entry" (org-cite-basic-goto !citation-object !prefix-argument))
+ ("w" "Browse URL/DOI"
+ (let ((url (org-cite-basic--get-url !citation-object))
+ (doi (org-cite-basic--get-doi !citation-object)))
+ (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-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)))))]]
+ (org-cite-basic-goto !citation-object !prefix-argument)
+ (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 (_)
@@ -1003,7 +1054,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..1e9dd60fe
--- /dev/null
+++ b/lisp/om.el
@@ -0,0 +1,275 @@
+;;; om.el --- Org Menu library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2025 Free Software Foundation, Inc.
+
+;; Author: Tor-björn Claesson <tclaes...@gmail.com>
+
+;; 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 for inverting the behaviour of Org menus with regards to
+`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 (specifications), where SPECIFICATIONS"
+ :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 specifications)
+ "Make BINDINGS visible to commands in SPECIFICATIONS."
+ `(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))
+ ,specifications))
+
+(cl-defmacro org-menu--with-arguments (arg-list &body body)
+ "Makes the arguments, prefixed with !, visible to BODY."
+ `(dlet ,(mapcar (lambda (arg)
+ `(,(intern (concat "!" (symbol-name arg))) ,arg))
+ arg-list)
+ ,@body))
+
+(defun org-menu--specifications-to-menu (description specifications)
+ "Given SPECIFICATIONS (on the form of `org-cite-basic-follow-actions'),
+return a menu keymap with those bidings.
+
+The title of this menu is DESCRIPTION."
+ (let ((new-map (make-sparse-keymap description)))
+ (cl-loop
+ for group across specifications
+ do (cl-loop
+ for specification across group
+ do
+ (pcase specification
+ (`(,key ,desc ,fn . ,_)
+ (define-key new-map key `(menu-item ,desc ,fn))))))
+ new-map))
+
+(defun org-menu-popup (description specifications)
+ "Show an org-menu using a popup-menu.
+
+This function is a valid value for `org-menu-system'."
+ (let ((menu-keymap (org-menu--specifications-to-menu description specifications)))
+ (popup-menu menu-keymap)))
+
+
+(defmacro org-menu--defcustom-actions (menu-actions value menu-name)
+ "Define MENU-ACTIONS option for MENU-NAME with default VALUE."
+ `(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))
+
+(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."
+ `(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))
+
+;;; Main macro definition
+(cl-defmacro org-menu-define
+ (name arglist docstring description contents default-action &body body)
+ "Define an org menu NAME.
+
+A function called NAME will be created to activate the menu.
+
+ARGLIST is the name of the arguments given to this function.
+Unless it ends in prefix-argument, this will be appended.
+
+DOCSTRING is the menu docstring.
+
+DESCRIPTION is a short menu title, shown to explain the function
+of the menu while in use.
+
+CONTENTS is the contents of the menu. 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'.
+
+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).
+
+BODY is optional and can be used to set up the interactive
+environemnt and validate arguments."
+ (declare (indent defun))
+ (let ((menu-default-action
+ (intern (concat (symbol-name name) "-default-action")))
+ (menu-actions
+ (intern (concat (symbol-name name) "-actions")))
+ (complete-arglist (if (member 'prefix-argument arglist)
+ arglist
+ `(,@arglist prefix-argument))))
+ `(progn
+ (org-menu--defcustom-actions
+ ,menu-actions ',contents ,name)
+ (org-menu--defcustom-default-action
+ ,menu-default-action ',default-action ,name ',complete-arglist)
+
+ (transient-define-prefix
+ ,name (,@arglist &optional prefix-argument)
+ ,docstring
+ [:class
+ transient-columns
+ :setup-children
+ (lambda (_)
+ (transient-parse-suffixes
+ ',name
+ (org-menu--bind-specification
+ (mapcar
+ (lambda (arg)
+ `(,(intern (concat "!" (symbol-name arg)))
+ (plist-get (transient-scope)
+ ,(intern (concat ":" (symbol-name arg))))))
+ ',complete-arglist)
+ ,menu-actions)))
+ :pad-keys t]
+ ;; Make sure we have an interactive body
+ ,@(if (and (listp body)
+ (and (listp (car body))
+ (eq (caar body) 'interactive)))
+ body
+ `((interactive (list (org-element-context)))
+ ,@body))
+ ;; Should we display a menu? If so, how?
+ (cond ((not (xor org-menu-mode
+ (eq prefix-argument org-menu-switch)))
+ ;; Call the default action
+ (org-menu--with-arguments
+ ,complete-arglist
+ (eval ,menu-default-action)))
+ ((eq org-menu-system 'transient)
+ ;; Activate transient
+ (transient-setup
+ (quote ,name) nil nil
+ :scope (list
+ ,@(mapcan (lambda (parameter)
+ (list (intern
+ (concat ":"
+ (symbol-name parameter)))
+ parameter))
+ complete-arglist))))
+ (t
+ ;; Use the system specified in `org-menu-system'
+ (funcall
+ org-menu-system
+ ,description
+ (org-menu--bind-specification
+ (list ,@(cl-mapcar
+ (lambda (param)
+ `(list
+ ',(intern (concat "!" (symbol-name param)))
+ `',,param))
+ complete-arglist))
+ ,menu-actions))))))))
+
+(provide 'om)
+;;; om.el ends here
--
2.47.2
