Ihor Radchenko <yanta...@posteo.net> writes:
> Thanks for your efforts!
> The docstrings should indeed be improved. Writing the docstrings often
> reveals the edge cases missed in the code itself.
Thanks, I have tried to improve the docstrings.
>
>> + (complete-arglist (if (member 'prefix-argument arglist)
>> + arglist
>> + `(,@arglist prefix-argument))))
>> ...
>> + (transient-define-prefix
>> + ,name (,@arglist &optional prefix-argument)
>
> This will fail when (1) arglist already contains prefix-argument or (2)
> arglist has &optional/&rest of its own.
>
> We should
> (1) Alter
> (mapcar
> (lambda (arg)
> `(,(intern (concat "!" (symbol-name arg)))
> (plist-get (transient-scope)
> ,(intern (concat ":" (symbol-name arg))))))
> ',complete-arglist)
>
> to filter out &optional and &rest
>
> (2) Probably change the way we introduce prefix argument.
> For example, instead of fiddling with (interactive ...) and argument
> list, we can make use of current-prefix-arg variable to check
> org-menu-switch.
>
I have gotten rid of complete-arglist, changed the org-cite-basic-follow
definition to specify the complete argument list, use current-prefix-arg
for the switch thing, and made a function to filter out &optional etc.
This feels better, is it good enough?
>> (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))
>
> I think that we should also put group names like "Open" or "Copy" as
> non-clickable (menu-item ITEM-NAME), maybe even adding a separator below.
Good idea. I improved the function to produce a (flat) menu, with
separator for all but the first heading. Should this be flat, or should
we have submenues? This could maybe depend on how many entries there are.
> Also, here is a version for menu system using tmm menu:
>
> (defun org-menu-tmm-prompt (description specifications)
> "Show an org-menu using a `tmm-prompt'.
>
> This function is a valid value for `org-menu-system'."
> (let ((menu-keymap (org-menu--specifications-to-menu description
> specifications)))
> (tmm-prompt menu-keymap)))
Thanks! It is fun when it starts coming together!
/Tor-björn
>From b0174f3c7b71257d68907abbb9bdf23371e17b34 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 | 74 +++++++++--
lisp/om.el | 319 +++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 384 insertions(+), 9 deletions(-)
create mode 100644 lisp/om.el
diff --git a/lisp/oc-basic.el b/lisp/oc-basic.el
index fb6d9477a..f789eb3bc 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,45 @@ present in the citation."
(bibtex-set-dialect)
(bibtex-search-entry key)))))
+(org-menu-define org-cite-basic-follow (citation-object &optional prefix-argument)
+ "Basic citation follower.
+
+Open citations by applying the function in
+`org-cite-basic-follow-default-action'. If `org-menu-mode' is active, display a
+menu specified in `org-cite-basic-follow-actions'. This behaviour can be inverted
+by giving the prefix argument in `org-menu-switch'. See `org-menu-mode' for more information."
+ "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 (_)
@@ -1006,7 +1062,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..6429fc9aa
--- /dev/null
+++ b/lisp/om.el
@@ -0,0 +1,319 @@
+;;; 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 specification)
+ "Make BINDINGS visible to commands in SPECIFICATION."
+ `(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)
+ "Makes 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)
+ "Given SPECIFICATION (on the form of `org-cite-basic-follow-actions'),
+return a flattened menu keymap with those bidings.
+
+The title of this menu is DESCRIPTION."
+ (let ((new-map (make-sparse-keymap description)))
+ (named-let populate-menu-keymap
+ ;; First, make a flat reversed list of menu items. Items have the forms:
+ ;; ("title" MENU-HEADING) or
+ ;; (KEY DESCRIPTION BINDING)
+ ((posts (named-let build-list ((menu specification))
+ (if (equal menu [])
+ '()
+ (let ((first (aref menu 0))
+ (rest (seq-subseq menu 1)))
+ (append (build-list rest)
+ (pcase first
+ ((pred vectorp)
+ (build-list first))
+ ((pred stringp)
+ `(("title" ,first)))
+ (`(,key ,desc ,function)
+ `((,key ,desc ,function)))))))))
+ (row 0)) ;; Keep track of row number to give menu heading unique keys
+ (if (null posts)
+ new-map
+ (progn
+ (pcase (car posts)
+ (`("title" ,heading)
+ (define-key new-map `[,(make-symbol
+ (concat "header-"
+ (number-to-string row)))]
+ `(menu-item ,heading))
+ (unless (null (cdr posts)) ;; No separator if first heading
+ (define-key new-map `[,(make-symbol
+ (concat "[separator-"
+ (number-to-string row)
+ "]"))]
+ '(menu-item "--"))))
+ (`(,key ,desc ,function)
+ (define-key new-map key `(menu-item ,desc ,function))))
+ (populate-menu-keymap (cdr posts) (+ row 1)))))))
+
+(defun org-menu-popup (description specification)
+ "Show an org-menu using a popup-menu.
+
+This function is a valid value for `org-menu-system'."
+ (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'."
+ (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."
+ `(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))
+
+(defun org-menu--strip-argument-decorators (arglist)
+ "Return a copy of ARGLIST without &optional, &body, &key, &aux, or &rest."
+ (seq-filter
+ (lambda (elt)
+ (not (or (eq elt '&optional)
+ (eq elt '&body)
+ (eq elt '&rest)
+ (eq elt '&aux)
+ (eq elt '&key))))
+ arglist))
+
+(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.
+
+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"))))
+ `(progn
+ (org-menu--defcustom-actions
+ ,menu-actions ',contents ,name)
+ (org-menu--defcustom-default-action
+ ,menu-default-action
+ ',default-action
+ ,name
+ ',(org-menu--strip-argument-decorators arglist))
+
+ (transient-define-prefix
+ ,name ,arglist
+ ,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))))))
+ `',@(org-menu--strip-argument-decorators ',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 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 org-menu-system 'transient)
+ ;; Activate transient
+ (transient-setup
+ (quote ,name) nil nil
+ :scope (list
+ ,@(mapcan (lambda (parameter)
+ (list (intern
+ (concat ":"
+ (symbol-name parameter)))
+ parameter))
+ (org-menu--strip-argument-decorators 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))
+ (org-menu--strip-argument-decorators arglist)))
+ ,menu-actions))))))))
+
+(provide 'om)
+;;; om.el ends here
--
2.47.2
