From 203153bfb3e49c82995f721518596a2b00127467 Mon Sep 17 00:00:00 2001 From: MT Date: Wed, 10 May 2023 17:38:22 +0200 Subject: [PATCH 2/2] * lisp/ob-core.el: Rewrite of merge babel headers (org-babel-merge-params): merge headers strategy split out into new dedicated function `--merge-headers' (org-babel--merge-headers): new function that resolves headers based on their mutually exclusive groups, with better support for groups with `:any' keywords. (org-babel-common-header-args-w-values): Added mutually exclusive tangle groups relating to desired tangle sync actions * testing/lisp/test-ob.el: update tests according to new merge strategy, with emphasis on `:tangle' headers for syncing actions. --- lisp/ob-core.el | 142 +++++++++++++++++++++++++++++++--------- testing/lisp/test-ob.el | 11 ++-- 2 files changed, 116 insertions(+), 37 deletions(-) diff --git a/lisp/ob-core.el b/lisp/ob-core.el index 606c3efec..48337406a 100644 --- a/lisp/ob-core.el +++ b/lisp/ob-core.el @@ -437,7 +437,8 @@ then run `org-babel-switch-to-session'." (sep . :any) (session . :any) (shebang . :any) - (tangle . ((tangle yes no :any))) + (tangle . ((tangle yes no :any) + (import export skip sync))) (tangle-mode . ((#o755 #o555 #o444 :any))) (var . :any) (wrap . :any)) @@ -2836,6 +2837,89 @@ specified as an an \"attachment:\" style link." (goto-char body-start) (insert body)))) +(defun org-babel--merge-headers (exclusive-groups &rest result-params) + "Maintain exclusivity of mutually exclusive parameters, as defined +in EXCLUSIVE-GROUPS while merging lists in RESULT-PARAMS." + (cl-flet ((alist-append (alist key val) + (let ((existing (cdr (assoc key alist)))) + (if existing + (setcdr (assoc key alist) (append existing (list val))) + (setq alist (cons (cons key (list val)) alist))) + alist))) + ;; + ;; Problem: Having an :any keyword in an exclusion group means + ;; that a parameter of "yes" could match to an exclusion + ;; group that contains both "yes" AND ":any". + ;; + ;; Solution: For each parameter, build a list of exclusion groups + ;; it could belong to. If a parameter belongs to two + ;; groups, eliminate it from the group that contains the + ;; ":any" keyword. + ;; + ;; Details: Exclusion groups (e.g.'("tangle" "yes" "no" ":any") ) + ;; are referenced to by their car ("tangle"), acting as + ;; a key for the entire group. + ;; + ;; Assumption: The order of RESULT-PARAMS dictate the hierarchy of + ;; the cascading headers. + ;; + (let ((any-group-key ;; exclusion group key for group with :any keyword + (caar (cl-remove-if-not (lambda (x) (member ":any" x)) exclusive-groups))) + params-alist ;; param -> list( exclusion group keys ) + unexplained-params) ;; any params that were not caught + + ;; Iterate parameters, across each exclusion group. + ;; - Populate params-alist + (dolist (new-params result-params) + (dolist (new-param new-params) + (dolist (exclusive-group exclusive-groups) + (if (or (member new-param exclusive-group) + (and (string= (car exclusive-group) any-group-key) + ;; param *doesn't* match a keyword in this + ;; :any group? Could be :any. + (not (member new-param exclusive-group)))) + (let ((group-key (car exclusive-group))) + (setq params-alist (alist-append params-alist new-param group-key))) + ;; Some parameters fit into no groups, store them and process later. + (push new-param unexplained-params))))) + + (delete-dups unexplained-params) + + ;; Find parameters listed in 2 or more exclusive groups, and kick + ;; them out of any non-":any" group. + ;; - Update params-alist + ;; - Remove uniquely known params from unexplained-params + (dolist (parm-vals params-alist) + (let ((parm (car parm-vals)) + (group-keys (cdr parm-vals))) + (if (member parm unexplained-params) + (setq unexplained-params (delete parm unexplained-params))) + (if (> (length group-keys) 1) + (dolist (gkey group-keys) + (if (string= gkey any-group-key) + (setcdr (assoc parm params-alist) (delete gkey group-keys))))))) + + ;; Collapse parameters into exclusion groups + ;; - convert params → list(exclusion group keys) to exclusion-group-key → list(params) + ;; - e.g.'(("sync" "import")("/tmp/sublow" "tangle")("/tmp/low" "tangle")("no" "tangle")) + (let (group-alist) + (mapcar (lambda (x) (setq group-alist (alist-append group-alist (cadr x) (car x)))) params-alist) + ;; - e.g. '(("tangle" "/tmp/sublow" "/tmp/low" "no") ("import" "sync"))) + ;;;;(setq group-alist (mapcar #'cadr group-alist)) + + ;; Set values in the same order that the exclusion groups are defined + (let ((group-key-order (mapcar #'car exclusive-groups))) + (setq group-alist (cl-remove-if-not #'identity + (mapcar (lambda (x) (car (alist-get x group-alist))) + group-key-order)))) + + ;; Final Sanity Check: were all parameters explained? + ;; - if not, append to result + (if unexplained-params + (setq group-alist (append unexplained-params group-alist))) + group-alist)))) + + (defun org-babel-merge-params (&rest plists) "Combine all parameter association lists in PLISTS. Later elements of PLISTS override the values of previous elements. @@ -2847,26 +2931,15 @@ parameters when merging lists." (exports-exclusive-groups (mapcar (lambda (group) (mapcar #'symbol-name group)) (cdr (assq 'exports org-babel-common-header-args-w-values)))) - (merge - (lambda (exclusive-groups &rest result-params) - ;; Maintain exclusivity of mutually exclusive parameters, - ;; as defined in EXCLUSIVE-GROUPS while merging lists in - ;; RESULT-PARAMS. - (let (output) - (dolist (new-params result-params (delete-dups output)) - (dolist (new-param new-params) - (dolist (exclusive-group exclusive-groups) - (when (member new-param exclusive-group) - (setq output (cl-remove-if - (lambda (o) (member o exclusive-group)) - output)))) - (push new-param output)))))) + (tangle-exclusive-groups + (mapcar (lambda (group) (mapcar #'symbol-name group)) + (cdr (assq 'tangle org-babel-common-header-args-w-values)))) (variable-index 0) ;Handle positional arguments. clearnames params ;Final parameters list. ;; Some keywords accept multiple values. We need to treat ;; them specially. - vars results exports) + vars results exports tangle) (dolist (plist plists) (dolist (pair plist) (pcase pair @@ -2901,22 +2974,28 @@ parameters when merging lists." (t (error "Variable \"%s\" must be assigned a default value" (cdr pair)))))) (`(:results . ,value) - (setq results (funcall merge - results-exclusive-groups - results - (split-string - (cond ((stringp value) value) - ((functionp value) (funcall value)) + (setq results (org-babel--merge-headers + results-exclusive-groups + results + (split-string + (cond ((stringp value) value) + ((functionp value) (funcall value)) ;; FIXME: Arbitrary code evaluation. - (t (eval value t))))))) + (t (eval value t))))))) (`(:exports . ,value) - (setq exports (funcall merge - exports-exclusive-groups - exports - (split-string - (cond ((and value (functionp value)) (funcall value)) - (value value) - (t "")))))) + (setq exports (org-babel--merge-headers + exports-exclusive-groups + exports + (split-string + (cond ((and value (functionp value)) (funcall value)) + (value value) + (t "")))))) + (`(:tangle . ,value) + (setq tangle (org-babel--merge-headers + tangle-exclusive-groups + tangle + (split-string + (or value ""))))) ((or '(:dir . attach) '(:dir . "'attach")) (unless (org-attach-dir nil t) (error "No attachment directory for element (add :ID: or :DIR: property)")) @@ -2942,7 +3021,8 @@ parameters when merging lists." params))))) ;; Handle other special keywords, which accept multiple values. (setq params (nconc (list (cons :results (mapconcat #'identity results " ")) - (cons :exports (mapconcat #'identity exports " "))) + (cons :exports (mapconcat #'identity exports " ")) + (cons :tangle (mapconcat #'identity tangle " "))) params)) ;; Return merged params. (org-babel-eval-headers params))) diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el index f12533258..a58a47052 100644 --- a/testing/lisp/test-ob.el +++ b/testing/lisp/test-ob.el @@ -337,7 +337,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf #+end_src" (test-ob/get-src-block-property :tangle)))) - (should-not ;; 2. inherit-document-header-with-local-sync-action + (should ;; 2. inherit-document-header-with-local-sync-action ;; This should pass with newer merge function with multiple tangle parameters (equal '(:tangle "/tmp/default_tangle.txt skip") (org-test-with-temp-text @@ -377,7 +377,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf :tangle randomfile #+end_src" (test-ob/get-src-block-property '(:tangle :results))))) - (should-not ;; 6. inherit-document-tfile-take-only-last-local-sync-action + (should ;; 6. inherit-document-tfile-take-only-last-local-sync-action ;; This should pass with newer merge function with multiple tangle parameters (equal '(:tangle "/tmp/default_tangle.txt export") (org-test-with-temp-text @@ -387,7 +387,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf :tangle import export #+end_src" (test-ob/get-src-block-property :tangle)))) - (should-not ;; 7. ignore-document-header-take-last-tfile-and-sync-action + (should ;; 7. ignore-document-header-take-last-tfile-and-sync-action ;; This should pass with newer merge function with multiple tangle parameters (equal '(:tangle "fname2 export") (org-test-with-temp-text @@ -426,9 +426,8 @@ PROPERTIES is a list of property keywords or a single keyword." #+begin_src conf :tangle \"foo.txt\" :comments link #+end_src" (test-ob/get-src-block-property '(:tangle :exports :comments))))) - (should-not ;; 11. override-document-and-heading-tfile-with-yes - ;; This should pass with newer merge function with multiple tangle parameters - (equal '(:tangle "foo.txt") + (should ;; 11. override-document-and-heading-tfile-with-yes + (equal '(:tangle "yes") (org-test-with-temp-text "\ #+PROPERTY: header-args :tangle /tmp/default_tangle.txt -- 2.41.0