From 1866c082547f75f38e221117e4eff2f0124d69f7 Mon Sep 17 00:00:00 2001 From: Mehmet Tekman Date: Wed, 10 May 2023 17:38:22 +0200 Subject: [PATCH 2/3] * 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. * lisp/test-ob.el (test-ob/merge-params): Very minor test value update due to rewrite --- lisp/ob-core.el | 154 +++++++++++++++++++++++++++++++--------- testing/lisp/test-ob.el | 4 +- 2 files changed, 123 insertions(+), 35 deletions(-) diff --git a/lisp/ob-core.el b/lisp/ob-core.el index fb9df80c3..cd6c6708c 100644 --- a/lisp/ob-core.el +++ b/lisp/ob-core.el @@ -2843,6 +2843,88 @@ specified as an an \"attachment:\" style link." (goto-char body-start) (insert body)))) +(defun org-babel--merge-headers (exclusive-groups &rest related-params) + "Merge related cascading header parameters whilst upholding group exclusivity. + +A given header parameter (prop) can have multiple values +depending on where it is referenced in the outline path (olp) of +an Org document. The RELATED-PARAMS argument is a list that +contains the value of the prop at the current level of the olp, +as well the resolution of the last time this function was called +for the prop. The EXCLUSIVE-GROUPS argument contains the related +prop entry from `org-babel-common-header-args-w-values' and +dictates the valid values a prop can take. If the prop can have +more than one value, it defines consistent mutually exclusive +keywords that the prop can take." + ;; + ;; 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". + ;; + ;; 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. + ;; + ;; Exclusion groups are referenced to by their car, acting as a key + ;; for the entire group. + ;; + (let ((any-group-key ;; exclusion group key for group with :any keyword + ;; Ihor: cl-find is suggested here, but not sure how to apply. + (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 related-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))) + (push group-key (alist-get new-param params-alist nil nil #'equal))) + ;; Some parameters fit into no groups, store them and process later. + (push new-param unexplained-params))))) + + (setq 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 (delete-dups (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) + (let (group-alist) + (mapcar (lambda (x) + (let* ((key (cadr x)) + (val (car x)) + (existing (cdr (assoc key group-alist)))) + ;;(push val (alist-get key group-alist nil nil #'equal)) + (if existing + (setcdr (assoc key group-alist) (append existing (list val))) + (setq group-alist (cons (cons key (list val)) group-alist))))) + params-alist) + ;; Set values in the same order that the exclusion groups are defined + (let ((group-key-order (mapcar #'car exclusive-groups))) + (setq group-alist (delq nil (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. @@ -2854,26 +2936,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 @@ -2908,22 +2979,33 @@ 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 + (mapcar #'org-babel-read + (org-babel-balanced-split + (or value "") + (if (eq (car (text-properties-at 0 value)) + 'org-babel-quote) + ?\" + ?\s)))))) ((or '(:dir . attach) '(:dir . "'attach")) (unless (org-attach-dir nil t) (error "No attachment directory for element (add :ID: or :DIR: property)")) @@ -2949,7 +3031,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 #'substring-no-properties tangle " "))) params)) ;; Return merged params. (org-babel-eval-headers params))) @@ -3246,9 +3329,14 @@ situations in which is it not appropriate." ;; FIXME: Arbitrary code evaluation. (eval (read cell) t)) ((save-match-data - (and (string-match "^[[:space:]]*\"\\(.*\\)\"[[:space:]]*$" cell) - (not (string-match "[^\\]\"" (match-string 1 cell))))) - (read cell)) + (and (string-match (rx bol (* space) "\"" (group (* any)) "\"" (* space) eol) + cell) + (not (string-match (rx (not "\\") "\"") (match-string 1 cell))))) + (let ((res (read cell))) + ;; If the matched string contains quotes, add quote property + (if (string-match (rx bol "\"" (* any) "\"" eol) cell) + (put-text-property 0 (length res) 'org-babel-quote 't res)) + res)) (t (org-no-properties cell)))) (defun org-babel--string-to-number (string) diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el index 460afbf9b..48cb60e10 100644 --- a/testing/lisp/test-ob.el +++ b/testing/lisp/test-ob.el @@ -359,7 +359,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+end_src" (test-ob/get-src-block-property '(:mkdirp :dir :padline))))) (should - (equal '(:results "value code replace file" :file "file") + (equal '(:results "file code replace value" :file "file") (org-test-with-temp-text "\ #+PROPERTY: header-args :results file :file file @@ -368,7 +368,7 @@ PROPERTIES is a list of property keywords or a single keyword." #+end_src" (test-ob/get-src-block-property '(:results :file))))) (should - (equal '(:results "value html silent") + (equal '(:results "html silent value") (org-test-with-temp-text "\ #+PROPERTY: header-args :results file -- 2.41.0