From 32a2610cc301572bc14a6cb18d6138b653e91e80 Mon Sep 17 00:00:00 2001 From: TEC Date: Tue, 7 Feb 2023 01:57:06 +0800 Subject: [PATCH 5/6] ox: Add struct feature conditions/implementations * lisp/ox.el (org-export--annotate-info, org-export-detect-features, org-export-define-derived-backend, org-export-define-backend, org-export-conditional-features): Refactor backend feature conditions/implementations into a struct field. This allows for parent inheritance to be properly managed, and leads into future work making features more widely used in the export process. (org-export-expand-features, org-export-resolve-feature-implementations, org-export-generate-features-preamble, org-export-expand-feature-snippets): Rework `org-export-expand-features` into `org-export-resolve-feature-implementations`, and `org-export-generate-features-preamble` into `org-export-expand-feature-snippets`. (org-export-process-features, org-export-update-features): Introduce `org-export-process-features' to simplify the application of features to INFO. * lisp/ox-latex.el (org-latex-make-preamble): Move the LaTeX feature conditions/implementations into the backend definition, and use the reworked function `org-export-expand-feature-snippets'. --- lisp/ox-latex.el | 156 +++++++-------- lisp/ox.el | 482 ++++++++++++++++++++++++++++++++++------------- 2 files changed, 415 insertions(+), 223 deletions(-) diff --git a/lisp/ox-latex.el b/lisp/ox-latex.el index 040824f45..6221cc486 100644 --- a/lisp/ox-latex.el +++ b/lisp/ox-latex.el @@ -127,8 +127,6 @@ (org-export-define-backend 'latex (:description "DESCRIPTION" nil nil parse) (:keywords "KEYWORDS" nil nil parse) (:subtitle "SUBTITLE" nil nil parse) - (:conditional-features nil nil org-latex-conditional-features) - (:feature-implementations nil nil org-latex-feature-implementations) ;; Other variables. (:latex-active-timestamp-format nil nil org-latex-active-timestamp-format) (:latex-caption-above nil nil org-latex-caption-above) @@ -172,7 +170,64 @@ (org-export-define-backend 'latex (:latex-toc-command nil nil org-latex-toc-command) (:latex-compiler "LATEX_COMPILER" nil org-latex-compiler) ;; Redefine regular options. - (:date "DATE" nil "\\today" parse))) + (:date "DATE" nil "\\today" parse)) + :feature-conditions-alist + `((t !announce-start) + (t !announce-end) + (t !guess-pollyglossia) + (t !guess-babel) + (t !guess-inputenc) + (,(lambda (info) + (org-element-map (plist-get info :parse-tree) + '(latex-fragment latex-environment) #'identity info t)) + maths) + (,(lambda (info) + (org-element-map (plist-get info :parse-tree) + 'underline #'identity info t)) + underline) + ("\\\\uu?line\\|\\\\uwave\\|\\\\sout\\|\\\\xout\\|\\\\dashuline\\|\\dotuline\\|\\markoverwith" + underline) + (,(lambda (info) + (org-element-map (plist-get info :parse-tree) + 'link + (lambda (link) + (and (member (org-element-property :type link) + '("http" "https" "ftp" "file")) + (file-name-extension (org-element-property :path link)) + (equal (downcase (file-name-extension + (org-element-property :path link))) + "svg"))) + info t)) + svg) + (org-latex-tables-booktabs booktabs) + (,(lambda (info) + (eq (plist-get info :latex-src-block-backend) 'engraved)) + engraved-code) + ("^[ \t]*#\\+attr_latex: .*:float +wrap" + float-wrap) + ("^[ \t]*#\\+attr_latex: .*:float +sideways" + rotate) + ("^[ \t]*#\\+caption:\\|\\\\caption{" caption)) + :feature-implementations-alist + `((!announce-start + :snippet ,(lambda (info) + (format "\n%%%% ox-latex features: %s" + (plist-get info :features))) + :order -100) + (maths :snippet "\\usepackage{amsmath}\n\\usepackage{amssymb}" :order 0.2) + (underline :snippet "\\usepackage[normalem]{ulem}" :order 0.5) + (image :snippet "\\usepackage{graphicx}" :order 2) + (svg :snippet "\\usepackage[inkscapelatex=false]{svg}" :order 2 :when image) + (longtable :snippet "\\usepackage{longtable}" :when table :order 2) + (booktabs :snippet "\\usepackage{booktabs}" :when table :order 2) + (float-wrap :snippet "\\usepackage{wrapfig}" :order 2) + (rotate :snippet "\\usepackage{rotating}" :order 2) + (caption :snippet "\\usepackage{capt-of}") + (engraved-code :snippet org-latex-generate-engraved-preamble :when code) + (!guess-pollyglossia :snippet org-latex-guess-polyglossia-language) + (!guess-babel :snippet org-latex-guess-babel-language) + (!guess-inputenc :snippet org-latex-guess-inputenc) + (!announce-end :snippet "%% end ox-latex features\n" :order 100))) @@ -1380,94 +1435,6 @@ (defun org-latex-generate-engraved-preamble (info) "% WARNING syntax highlighting unavailable as engrave-faces-latex was missing.\n") "\n"))) -;;;; Generated preamble - -(defcustom org-latex-conditional-features - `((t . !announce-start) - (t . !announce-end) - (t . !guess-pollyglossia) - (t . !guess-babel) - (t . !guess-inputenc) - (,(lambda (info) - (org-element-map (plist-get info :parse-tree) - '(latex-fragment latex-environment) #'identity info t)) - . maths) - (,(lambda (info) - (org-element-map (plist-get info :parse-tree) - 'underline #'identity info t)) - . underline) - ("\\\\uu?line\\|\\\\uwave\\|\\\\sout\\|\\\\xout\\|\\\\dashuline\\|\\dotuline\\|\\markoverwith" - . underline) - (,(lambda (info) - (org-element-map (plist-get info :parse-tree) - 'link - (lambda (link) - (and (member (org-element-property :type link) - '("http" "https" "ftp" "file")) - (file-name-extension (org-element-property :path link)) - (equal (downcase (file-name-extension - (org-element-property :path link))) - "svg"))) - info t)) - . svg) - (org-latex-tables-booktabs . booktabs) - (,(lambda (info) - (eq (plist-get info :latex-src-block-backend) 'engraved)) - . engraved-code) - ("^[ \t]*#\\+attr_latex: .*:float +wrap" - . float-wrap) - ("^[ \t]*#\\+attr_latex: .*:float +sideways" - . rotate) - ("^[ \t]*#\\+caption:\\|\\\\caption{" . caption)) - "A LaTeX-specific extension to `org-export-conditional-features', which see.") - -(defcustom org-latex-feature-implementations - `((!announce-start - :snippet ,(lambda (info) - (format "\n%%%% ox-latex features: %s" - (plist-get info :features))) - :order -100) - (maths :snippet "\\usepackage{amsmath}\n\\usepackage{amssymb}" :order 0.2) - (underline :snippet "\\usepackage[normalem]{ulem}" :order 0.5) - (image :snippet "\\usepackage{graphicx}" :order 2) - (svg :snippet "\\usepackage[inkscapelatex=false]{svg}" :order 2 :when image) - (longtable :snippet "\\usepackage{longtable}" :when table :order 2) - (booktabs :snippet "\\usepackage{booktabs}" :when table :order 2) - (float-wrap :snippet "\\usepackage{wrapfig}" :order 2) - (rotate :snippet "\\usepackage{rotating}" :order 2) - (caption :snippet "\\usepackage{capt-of}") - (engraved-code :snippet org-latex-generate-engraved-preamble :when code) - (!guess-pollyglossia :snippet org-latex-guess-polyglossia-language) - (!guess-babel :snippet org-latex-guess-babel-language) - (!guess-inputenc :snippet org-latex-guess-inputenc) - (!announce-end :snippet "%% end ox-latex features\n" :order 100)) - "Alist describing how export features should be supported in the preamble. - -Implementation alist has the feature symbol as the car, with the -cdr forming a plist with the following keys: -- :snippet, which is either, - - A string, which should be included in the preamble verbatim. - - A variable, the value of which should be included in the preamble. - - A function, which is called with two arguments — the export info, - and the list of feature flags. The returned value is included in - the preamble. -- :requires, a feature or list of features which are needed. -- :when, a feature or list of features which imply this feature. -- :prevents, a feature or list of features that should be masked. -- :order, for when inclusion order matters. Feature implementations - with a lower order appear first. The default is 0." - :group 'org-export-general - :type '(plist :key-type - (choice (const :snippet) - (const :requires) - (const :when) - (const :prevents) - (const :order) - (const :trigger)) - :value-type - (choice (string :tag "Verbatim content") - (variable :tag "Content variable") - (function :tag "Generating function")))) ;; Citation features (org-export-update-features 'latex @@ -2086,7 +2053,12 @@ (defun org-latex-make-preamble (info &optional template snippet?) (org-latex-guess-babel-language info) (org-latex-guess-polyglossia-language info) "\n% Generated preamble omitted for snippets.") - (org-export-generate-features-preamble info))) + (concat + "\n" + (string-join + (org-export-expand-feature-snippets info) + "\n\n") + "\n"))) (concat ;; Time-stamp. (and (plist-get info :time-stamp-file) diff --git a/lisp/ox.el b/lisp/ox.el index 32f1c6016..6c7a11b66 100644 --- a/lisp/ox.el +++ b/lisp/ox.el @@ -1030,7 +1030,7 @@ ;;; Defining Back-ends (cl-defstruct (org-export-backend (:constructor org-export-create-backend) (:copier nil)) - name parent transcoders options filters blocks menu) + name parent transcoders options filters blocks menu feature-conditions feature-implementations) ;;;###autoload (defun org-export-get-backend (name) @@ -1136,6 +1136,62 @@ (defun org-export-get-all-filters (backend) (setq filters (append filters (org-export-backend-filters backend)))) filters))) +(defvar org-export-conditional-features) + +(defun org-export-get-all-feature-conditions (backend) + "Return full feature condition alist for BACKEND. + +BACKEND is an export back-end, as return by, e.g,, +`org-export-create-backend'. Return value is an alist where keys +are feature conditions, and values are feature symbols. + +Unlike `org-export-backend-feature-conditions', this function +also returns conditions inherited from parent back-ends, if any." + (when (symbolp backend) (setq backend (org-export-get-backend backend))) + (and backend + (let ((conditions (org-export-backend-feature-conditions backend)) + parent) + (while (setq parent (org-export-backend-parent backend)) + (setq backend (org-export-get-backend parent)) + (dolist (condition (org-export-backend-feature-conditions backend)) + (push condition conditions))) + (dolist (condition org-export-conditional-features) + (unless (assq (car condition) conditions) + (push condition conditions))) + conditions))) + +(defun org-export-get-all-feature-implementations (backend) + "Return full feature implementation alist for BACKEND. + +BACKEND is an export back-end, as return by, e.g,, +`org-export-create-backend'. Return value is an alist where keys +are feature symbols, and values are an implementation +specification plist. + +Unlike `org-export-backend-feature-implementations', this function +also returns implementations inherited from parent back-ends, if any." + (when (symbolp backend) (setq backend (org-export-get-backend backend))) + (and backend + (let ((implementations (org-export-backend-feature-implementations backend)) + parent) + (while (setq parent (org-export-backend-parent backend)) + (setq backend (org-export-get-backend parent)) + (dolist (implementation (org-export-backend-feature-implementations backend)) + (unless (assq (car implementation) implementations) + (push implementation implementations)))) + implementations))) + +(defun org-export-install-features (info) + "Install feature conditions and implementations in the communication channel. +INFO is a plist containing the current communication channel. +Return the updated communication channel." + (plist-put info :feature-conditions + (org-export-get-all-feature-conditions + (plist-get info :back-end))) + (plist-put info :feature-implementations + (org-export-get-all-feature-implementations + (plist-get info :back-end)))) + (defun org-export-define-backend (backend transcoders &rest body) "Define a new back-end BACKEND. @@ -1247,20 +1303,24 @@ (defun org-export-define-backend (backend transcoders &rest body) `org-export-options-alist' for more information about structure of the values." (declare (indent 1)) - (let (filters menu-entry options) + (let (filters menu-entry options feature-conditions feature-implementations) (while (keywordp (car body)) (let ((keyword (pop body))) (pcase keyword (:filters-alist (setq filters (pop body))) (:menu-entry (setq menu-entry (pop body))) (:options-alist (setq options (pop body))) + (:feature-conditions-alist (setq feature-conditions (pop body))) + (:feature-implementations-alist (setq feature-implementations (pop body))) (_ (error "Unknown keyword: %s" keyword))))) (org-export-register-backend (org-export-create-backend :name backend :transcoders transcoders :options options :filters filters - :menu menu-entry)))) + :menu menu-entry + :feature-conditions feature-conditions + :feature-implementations feature-implementations)))) (defun org-export-define-derived-backend (child parent &rest body) "Create a new back-end as a variant of an existing one. @@ -1307,7 +1367,7 @@ (defun org-export-define-derived-backend (child parent &rest body) (org-export-to-buffer \\='my-latex \"*Test my-latex*\")" (declare (indent 2)) - (let (filters menu-entry options transcoders) + (let (filters menu-entry options transcoders feature-conditions feature-implementations) (while (keywordp (car body)) (let ((keyword (pop body))) (pcase keyword @@ -1315,6 +1375,8 @@ (defun org-export-define-derived-backend (child parent &rest body) (:menu-entry (setq menu-entry (pop body))) (:options-alist (setq options (pop body))) (:translate-alist (setq transcoders (pop body))) + (:feature-conditions-alist (setq feature-conditions (pop body))) + (:feature-implementations-alist (setq feature-implementations (pop body))) (_ (error "Unknown keyword: %s" keyword))))) (org-export-register-backend (org-export-create-backend :name child @@ -1322,7 +1384,9 @@ (defun org-export-define-derived-backend (child parent &rest body) :transcoders transcoders :options options :filters filters - :menu menu-entry)))) + :menu menu-entry + :feature-conditions feature-conditions + :feature-implementations feature-implementations)))) @@ -2031,7 +2095,7 @@ (defun org-export-expand (blob contents &optional with-affiliated) blob contents)))) -;;; Conditional/Generated Preamble +;;; Conditional/Generated Features ;; ;; Many formats have some version of a preamble, whether it be HTML's ;; ... or the content before LaTeX's \begin{document}. @@ -2042,12 +2106,35 @@ ;;; Conditional/Generated Preamble ;; with filters approach, but neither really solve this problem nicely. ;; ;; The conditional/generated preamble defines mechanisms of detecting -;; which "features" are used in a document, handles interactions -;; between features, and provides/generates preamble content to +;; which "export features" are used in a document, handles +;; interactions between features, and provides/generates content to ;; support the features. +;; +;; Each export feature condition takes the form of a +;; (CONDITION . FEATURES) cons cell (see `org-export-detect-features'), +;; and each implementation takes the form of a (FEATURE . (:KEY VALUE ...)) +;; associated plist (see `org-export-resolve-feature-implementations' +;; and `org-export-expand-feature-snippets'). +;; +;; This functionality is applied during export as follows: +;; 1. The export feature conditions and implementations are installed +;; into the INFO plist with `org-export-install-features'. +;; This simply applies `org-export-get-all-feature-conditions' and +;; `org-export-get-all-feature-implementations', which merges the +;; backend's conditions/implementations with all of it's parents and +;; finally the global condition list +;; `org-export-conditional-features'. +;; 2. The "export features" used in a document are detected with +;; `org-export-detect-features'. +;; 3. The interaction between different feature implementations is +;; resolved with `org-export-resolve-feature-implementations', +;; producing an ordered list of implementations to be actually used +;; in an export. +;; 4. The feature implementation's snippets are transformed into strings +;; to be inserted with `org-export-expand-feature-snippets'. (defcustom org-export-conditional-features - `(("^[ \t]*#\\+print_bibliography:" . bibliography) + `(("^[ \t]*#\\+print_bibliography:" bibliography) (,(lambda (info) (org-element-map (plist-get info :parse-tree) 'link @@ -2059,7 +2146,7 @@ (defcustom org-export-conditional-features (org-element-property :path link))) "svg"))) info t)) - . svg) + svg) (,(lambda (info) (org-element-map (plist-get info :parse-tree) 'link @@ -2071,69 +2158,95 @@ (defcustom org-export-conditional-features (org-element-property :path link))) image-file-name-extensions))) info t)) - . image) + image) (,(lambda (info) (org-element-map (plist-get info :parse-tree) 'table #'identity info t)) - . table) + table) (,(lambda (info) (org-element-map (plist-get info :parse-tree) '(src-block inline-src-block) #'identity info t)) - . code)) + code)) "Org feature tests and associated feature flags. Alist where the car is a test for the presense of the feature, and the CDR is either a single feature symbol or a list of feature symbols. -Feature tests can take any of the following forms: -- Variable symbol, the value of which is fetched. -- Function symbol, which is called with the export info - as the argument. -- A string, which is used as a regexp search in the buffer. - The regexp matching is taken as confirmation of the existence - of the feature. - -When the test is a variable or function and produces a string -value, that value is itself used as a test. Any other non-nil -value will imply the existance of the feature." +See `org-export-detect-features' for how this is processed." :group 'org-export-general :type '(alist :key-type (choice (regexp :tag "Feature test regexp") (variable :tag "Feature variable") (function :tag "Feature test function")) :value-type - (choice (symbol :tag "Feature symbol") - (repeat symbol :tag "Feature symbols")))) + (repeat symbol :tag "Feature symbols"))) (defun org-export-detect-features (info) - "Detect features from `org-export-conditional-features' in INFO." - (let (case-fold-search) - (delete-dups - (mapcan - (lambda (construct-feature) - (and (let ((out (pcase (car construct-feature) - ((pred stringp) (car construct-feature)) - ((pred functionp) - (funcall (car construct-feature) info)) - ((pred symbolp) (symbol-value (car construct-feature))) - (_ (error "org-export-conditional-features key %s unable to be used" (car construct-feature)))))) - (if (stringp out) - (save-excursion - (goto-char (point-min)) - (re-search-forward out nil t)) - out)) - (if (listp (cdr construct-feature)) - (copy-sequence (cdr construct-feature)) - (list (cdr construct-feature))))) - (append org-export-conditional-features - (plist-get info :conditional-features)))))) - -(defun org-export-expand-features (info) - "Identify all implied implementations from features, in INFO. - -(plist-get info :feature-implementations) should be an alist of feature symbols -and specification plists with the following keys: + "Detect features from `org-export-conditional-features' in INFO. + +More specifically, for each (CONDITION . FEATURES) cons cell of +the :feature-conditions list in INFO, the CONDITION is evaluated +in two phases. + +In phase one, CONDITION is transformed like so: +- If a variable symbol, the value is fetched +- If a function symbol, the function is called with INFO as the + sole argument +- If a string, passed on unmodified + +In phase two, if the CONDITION result is a string, it is used as +a case-sensitive regexp search in the buffer. The regexp +matching is taken as confirmation of the existance of FEATURES. +Any other non-nil value indicates the existance of FEATURES. + +A list of all detected feature symbols is returned. + +This function should be run in the processed export Org buffer, +after includes have been expanded and commented trees removed." + (delete-dups + (mapcan + (org-export--single-feature-detector info) + (plist-get info :feature-conditions)))) + +(defun org-export--single-feature-detector (info) + "Return a feature detection lambda that operates on INFO. + +The lambda has the signature ((CONDITION . FEATURES)), and +return FEATURES if CONDITION is found to apply. + +CONDITION is evaluated in the context of INFO and the current buffer, +in accordance with the docstring of `org-export-detect-features'. +`copy-sequence' is applied to the FEATURES list so that `nconc' can +safely be applied to it." + (lambda (condition-features) + (let ((condition (car condition-features)) + (features (cdr condition-features)) + (case-fold-search nil) + matcher) + (setq matcher + (cond + ((stringp condition) condition) + ((functionp condition) (funcall condition info)) + ((symbolp condition) (symbol-value condition)) + (t (error "org-export: Feature condition %s (for %s) unable to be used" + condition features)))) + (and (if (stringp matcher) + (save-excursion + (goto-char (point-min)) + (re-search-forward matcher nil t)) + matcher) + (copy-sequence features))))) + +(defun org-export-resolve-feature-implementations (info &optional features implementations) + "Resolve the IMPLEMENTATIONS of FEATURES, of INFO. + +FEATURES should be a list of all feature symbols to be resolved, +and defaults to (plist-get info :features). IMPLEMENTATIONS +should be an alist of feature symbols and specification plists, +and defaults to (plist-get info :feature-implementations). + +The following keys of the each implementation plist are recognised: - :snippet, which is either, - A string, which should be included in the preamble verbatim. - A variable, the value of which should be included in the preamble. @@ -2148,12 +2261,10 @@ (plist-get info :feature-implementations) should be an alist of feature symbols with a lower order appear first. The default is 0. This function processes :requires, :when, and :prevents in turn -before finally sorting according to :order. - -After resolving the features, the :features key of INFO is -updated to reflect the expanded set of features being used." - (let ((initial-features (plist-get info :features)) - (implementations (plist-get info :feature-implementations)) +before finally sorting according to :order. The final +implementation list is returned." + (let ((initial-features (or features (plist-get info :features))) + (implementations (or implementations (plist-get info :feature-implementations))) required-features current-implementations) ;; Process :requires. (while initial-features @@ -2214,79 +2325,188 @@ (plist-get info :feature-implementations) should be an alist of feature symbols (lambda (i) (memq (car i) prevented)) current-implementations)))) ;; Sort by :order. - (setq current-implementations - (sort current-implementations - (lambda (impl1 impl2) - (< (or (plist-get (cdr impl1) :order) 0) - (or (plist-get (cdr impl2) :order) 0))))) - ;; Update :features to reflect the features actually used. - (plist-put info :features (mapcar #'car current-implementations)) - current-implementations)) - -(defun org-export-generate-features-preamble (info) - "Generate preamble string according to features an implementations in INFO. -More specifically, this function resolves feature implementations -with `org-export-expand-features' and concatenates the snippets." - (let* ((feat-impl (org-export-expand-features info)) - (feat-snippets - (mapcar - (lambda (impl) - (let ((snippet (plist-get (cdr impl) :snippet))) + (sort current-implementations + (lambda (impl1 impl2) + (< (or (plist-get (cdr impl1) :order) 0) + (or (plist-get (cdr impl2) :order) 0)))))) + +(defun org-export-expand-feature-snippets (info &optional feature-implementations) + "Expand each of the feature :snippet keys in FEATURE-IMPLEMENTATIONS. +FEATURE-IMPLEMENTATIONS is expected to be a list of implementation +plists, if not provided explicitly it is extracted from the +:feature-implementations key of INFO. + +Each implementation plist's :snippet value is expanded in order, in +the following manner: +- nil values are ignored +- functions are called with INFO, and must produce a string or nil +- variable symbols use the value, which must be a string or nil +- strings are included verbatim +- all other values throw an `error'." + (let (expanded-snippets snippet value) + (dolist (impl (or feature-implementations + (plist-get info :feature-implementations))) + (setq snippet (plist-get (cdr impl) :snippet) + value (cond + ((null snippet) nil) + ((functionp snippet) (funcall snippet info)) + ((symbolp snippet) (symbol-value snippet)) + ((stringp snippet) snippet) + (t (error "org-export: The %s feature snippet %S is invalid (must be either nil, a function/variable symbol, or a string)" + (car impl) snippet)))) + (cond + ((stringp value) + (push value expanded-snippets)) + (value ; Non-string value, could come from function or variable. + (error "org-export: The %s feature snippet %s must give nil or a string, but instead gave %S" + (car impl) (cond - ((null snippet) nil) - ((functionp snippet) - (funcall snippet info)) - ((symbolp snippet) (symbol-value snippet)) - ((stringp snippet) snippet) - (t (error "org-export feature snippet %S is invalid." snippet) - nil)))) - feat-impl))) - (mapconcat - #'identity - (append (delq nil feat-snippets) (list "")) - "\n"))) - -(defun org-export-update-features (backend &rest feature-property-value-lists) - "For BACKEND's export spec, set all FEATURE-PROPERTY-VALUE-LISTS. - -Specifically, for each (FEATURE . PROPERTY-VALUE-LIST) entry of -FEATURE-PROPERTY-VALUE-LISTS, each :PROPERTY VALUE pair of -PROPERTY-VALUE-PAIRS is set to VALUE within the backend's feature -implementation plist. The sole exception to this is the -:condition property, the value of which is set in the backend's -feature condition plist instead. + ((and (functionp snippet) (symbolp snippet)) + (format "function (`%s')" snippet)) + ((functionp snippet) "anonymous function") + (t (format "variable (`%s')" snippet))) + value)))) + (nreverse expanded-snippets))) + +(defun org-export-process-features (info) + "Install feature conditions/implementations in INFO, and resolve them. +See `org-export-detect-features' and `org-export-resolve-feature-implementations' for +more information on what this entails." + (org-export-install-features info) + (let* ((features (org-export-detect-features info)) + (resolved-implementations + (org-export-resolve-feature-implementations info features))) + (plist-put info :feature-implementations resolved-implementations) + (plist-put info :features (mapcar #'car resolved-implementations)))) -This can be used to both modify existing entries, and create new ones. - -\(fn BACKEND &rest (FEATURE PROPERTY-VALUE-PAIRS...)...)" +;;;###autoload +(defmacro org-export-update-features (backend &rest feature-property-value-lists) + "For BACKEND's export spec, set each FEATURE's :PROPERTY to VALUE. + +The behaviour of this macro is best behaved with an example. +For instance, to add some preamble content from the variable +\"my-org-beamer-metropolis-tweaks\" when using the metropolis theme +with beamer export: + + (org-export-update-features \\='beamer + (beamer-metropolis + :condition (string-match-p \"metropolis$\" (plist-get info :beamer-theme)) + :snippet my-org-beamer-metropolis-tweaks + :order 3)) + +The modifies the beamer backend, either creating or updating the +\"beamer-metropolis\" feature. The :condition property adds a +condition which detects the feature, and all other properties are +applied to the feature's implementation plist. Setting +:condition to t means the feature will always be enabled, and +conversely setting :condition to nil means the feature will never +be enabled. + +When setting the :condition and :snippet properties, any sexp is +is implicitly converted to, + (lambda (info) SEXPR) + +Each (FEATURE . (:PROPERTY VALUE)) form that is processed is +taken from the single &rest argument +FEATURE-PROPERTY-VALUE-LISTS. + +\(fn BACKEND &rest (FEATURE . (:PROPERTY VALUE)...)...)" (declare (indent 1)) - (let ((backend-var (intern (format "org-%s-feature-implementations" backend))) - (backend-cf (intern (format "org-%s-conditional-features" backend)))) - (unless (boundp backend-var) - (error "Feature implementations for %s cannot be set as %s is undefined" - backend backend-var)) - (dolist (feature-property-value-set feature-property-value-lists) - (let ((feature (car feature-property-value-set)) - (property-value-pairs (copy-sequence (cdr feature-property-value-set)))) - (while property-value-pairs - (if (eq (car property-value-pairs) :condition) - (let ((condition (progn (pop property-value-pairs) - (pop property-value-pairs)))) - (unless (boundp backend-cf) - (error "Feature condition for %s cannot be set as %s is undefined" - backend backend-cf)) - (cond - ((rassoc feature (symbol-value backend-cf)) - (if condition - (setcar (rassoc feature (symbol-value backend-cf)) - condition) - (set backend-cf (delq (rassoc feature (symbol-value backend-cf)) - (symbol-value backend-cf))))) - (condition - (add-to-list backend-cf (cons condition feature))))) - (setf (alist-get feature (symbol-value backend-var)) - (plist-put (alist-get feature (symbol-value backend-var)) - (pop property-value-pairs) (pop property-value-pairs))))))))) + (org-with-gensyms (backend-struct the-entry the-features the-condition the-feat-impl cond-feat) + (let ((backend-expr + (if (and (eq (car-safe backend) 'quote) + (symbolp (cadr backend)) + (not (cddr backend))) + (or (org-export-get-backend (cadr backend)) + `(org-export-get-backend ',(cadr backend))) + `(if (symbolp ,backend) + (org-export-get-backend ,backend) + backend))) + (backend-impls + (list 'aref backend-struct + (cl-struct-slot-offset 'org-export-backend 'feature-implementations))) + (backend-conds + (list 'aref backend-struct + (cl-struct-slot-offset 'org-export-backend 'feature-conditions))) + body condition-set-p implementation-set-p) + (dolist (feature-property-value-set feature-property-value-lists) + (when (eq (car feature-property-value-set) 'quote) + (pop feature-property-value-set)) + (let ((features (car feature-property-value-set)) + (property-value-pairs (cdr feature-property-value-set)) + let-body property value) + (while property-value-pairs + (setq property (pop property-value-pairs) + value (pop property-value-pairs)) + (cond + ((consp value) + (unless (memq (car value) '(function quote)) + (if (and (memq property '(:condition :snippet)) + (not (functionp value))) + (setq value `(lambda (info) ,value)) + (setq value (list 'quote value))))) + ((memq value '(nil t))) ; Leave unmodified. + ((symbolp value) + (setq value (list 'quote value)))) + (if (eq property :condition) + (progn + (unless condition-set-p + (setq condition-set-p t)) + (push + (if value + (let ((the-features + (if (consp features) features (list features)))) + `(let* ((,the-condition ,value) + (,the-entry (assoc ,the-condition ,backend-conds))) + (if ,the-entry + (setcdr ,the-entry + (append ',the-features (cdr ,the-entry))) + (push (cons ,the-condition ',the-features) + ,backend-conds)))) + (let ((single-feature + (if (consp features) + (intern (string-join (mapcar #'symbol-name features) + "-and-")) + features))) + `(dolist (,cond-feat ,backend-conds) + (cond + ((equal (cdr ,cond-feat) (list ,single-feature)) + (setf ,backend-conds (delq ,cond-feat ,backend-conds))) + ((memq ,single-feature (cdr ,cond-feat)) + (setcdr ,cond-feat + (delq ,single-feature (cdr ,cond-feat)))))))) + body)) + (unless implementation-set-p + (setq implementation-set-p t)) + (push + (if let-body + `(plist-put (cdr ,the-feat-impl) ,property ,value) + `(setcdr ,the-feat-impl + (plist-put (cdr ,the-feat-impl) ,property ,value))) + let-body))) + (when let-body + (let ((the-feature + (if (consp features) + (intern (string-join (mapcar #'symbol-name features) + "-and-")) + features))) + (when (consp features) + (push + `(plist-put (cdr ,the-feat-impl) :when ',features) + let-body)) + (push + `(let ((,the-feat-impl + (or (assoc ',the-feature ,backend-impls) + (car (push (list ',the-feature ,property nil) + ,backend-impls))))) + ,@(nreverse let-body)) + body))))) + `(let ((,backend-struct ,backend-expr)) + ,@(and (not (org-export-backend-p backend-expr)) + `((unless (org-export-backend-p ,backend-struct) + (error "`%s' is not a loaded export backend" ,backend)))) + ,@(nreverse body) + nil)))) ;;; The Filter System @@ -3443,8 +3663,8 @@ (defun org-export--annotate-info (backend info &optional subtreep visible-only e ;; the output of the selected citation export processor. (org-cite-process-citations info) (org-cite-process-bibliography info) - ;; With the complete tree, detect features. - (plist-put info :features (org-export-detect-features info)) + ;; Install all the feature conditions and implementations. + (org-export-process-features info) info)) ;;;###autoload -- 2.39.0