Ihor Radchenko <yanta...@posteo.net> writes:
>
> Side note: I had one newly added test failing on the latest main. You
> may need to rebase your branch and check if tests are still passing.
>
The rebase was fine, but I'm having a problem aligning my patch branch
to work without any tangle involvement.
The first hurdle is that I'm a little bit unsure about the validity of one of
the tests.
* Under vanilla `org-babel-merge-params', any number of :tangle header
values are permitted and concatenated together.
e.g 4:
__________
´
(should ;; 4.
override-document-and-parent-header-with-local-tfile-and-action
(equal '(:tangle "randomfile sync")
(org-test-with-temp-text
"\
#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
* Four
:PROPERTIES:
:header-args: :tangle \"newfile.txt\" import
:END:
** A
#+begin_src conf :tangle randomfile sync
#+end_src"
(test-ob/get-src-block-property :tangle))))
`-----------
This result of "randomfile sync" for the :tangle header is seen as
valid.... but it shouldn't, should it? Tangle can only take one value,
so the action of `:any` should also just output one value?
From the docstring text:
> Symbol `:any' in the value list implies that any value is allowed.
It's not clear to me if this means that `:any' or `:any :any` or
`":any :any"` is permitted.
In my rewrite, I very much take the `:any` or `":any :any"` single
value interpretation when merging the headers together.
* Sometimes the value of another header is caught in the value of
another
e.g 8: "wrap" is caught in the output of `:results' despite it not being
a valid results keyword in `org-babel-common-header-args-w-values'.
__________
´
(should ;; 8. test-results-and-exports
(equal '(:results "wrap file replace" :exports "code")
(org-test-with-temp-text
"\
* Eight
#+begin_src sh :results file wrap
#+end_src"
(test-ob/get-src-block-property '(:results :exports)))))
(should ;; 9. do-not-tangle-this-block --
`-----------
This test results in "true" for both my rewrite, and the vanilla
function, but I'm not sure how accurate or value this is.
I've been reordering and splitting commits for a while now, but I think
it's really not easy to seperate the new tangle-sync component from my
merge-params rewrite.
I've attached my patches, including fixes from the last review you gave
- I hope you can make more sense of this than I can.
Best,
Mehmet
From bcbd184d7b7effa6cda1f6c3680a1e4a28b8be30 Mon Sep 17 00:00:00 2001
From: Mehmet Tekman <mtekma...@gmail.com>
Date: Tue, 1 Aug 2023 05:14:46 +0200
Subject: [PATCH 1/4] * testing/lisp/test-ob.el: New tests for merge-params
(test-ob/get-src-block-property):
(test-ob/merge-params): add new tests for the merge-params source
block header handling function.
---
testing/lisp/test-ob.el | 138 ++++++++++++++++++++++++++++++++++++++++
1 file changed, 138 insertions(+)
diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el
index c8dbd44f4..f12533258 100644
--- a/testing/lisp/test-ob.el
+++ b/testing/lisp/test-ob.el
@@ -314,6 +314,144 @@ this is simple"
(org-babel-next-src-block)
(should (= 14 (org-babel-execute-src-block)))))
+(defun test-ob/get-src-block-property (properties)
+ "Get plist of PROPERTIES and values for the first src block in buffer.
+PROPERTIES is a list of property keywords or a single keyword."
+ (org-with-wide-buffer
+ (goto-char (point-min))
+ (org-babel-next-src-block)
+ (org-set-regexps-and-options)
+ (let ((all-props (nth 2 (org-babel-get-src-block-info))))
+ (if (listp properties)
+ (apply #'nconc (mapcar (lambda (p) (list p (cdr (assoc p all-props)))) properties))
+ (list properties (cdr (assoc properties all-props)))))))
+
+(ert-deftest test-ob/merge-params ()
+ "Test the output of merging multiple header parameters."
+ (should ;; 1. inherit-document-header-args
+ (equal '(:tangle "/tmp/default_tangle.txt")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* One
+#+begin_src conf
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should-not ;; 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
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Two
+#+begin_src conf :tangle skip
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 3. override-document-header-with-local-tfile
+ (equal '(:tangle "randomfile sync")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Three
+#+begin_src conf :tangle randomfile sync
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 4. override-document-and-parent-header-with-local-tfile-and-action
+ (equal '(:tangle "randomfile sync")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Four
+:PROPERTIES:
+:header-args: :tangle \"newfile.txt\" import
+:END:
+** A
+#+begin_src conf :tangle randomfile sync
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 5. test-tangle-and-default-results-param-together
+ (equal '(:tangle "randomfile" :results "replace")
+ (org-test-with-temp-text
+ "\
+* Five
+#+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
+ ;; This should pass with newer merge function with multiple tangle parameters
+ (equal '(:tangle "/tmp/default_tangle.txt export")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Six
+#+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
+ ;; This should pass with newer merge function with multiple tangle parameters
+ (equal '(:tangle "fname2 export")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Seven
+#+begin_src conf :tangle fname1 fname2 sync export
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 8. test-results-and-exports
+ (equal '(:results "wrap file replace" :exports "code")
+ (org-test-with-temp-text
+ "\
+* Eight
+#+begin_src sh :results file wrap
+#+end_src"
+ (test-ob/get-src-block-property '(:results :exports)))))
+ (should ;; 9. do-not-tangle-this-block --
+ (equal '(:tangle "no")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Nine
+#+begin_src conf :tangle no
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 10. test-tangle-exports-and-comments
+ (equal '(:tangle "foo.txt" :exports "verbatim code" :comments "link")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Ten
+:PROPERTIES:
+:header-args: :tangle no :exports verbatim
+:END:
+#+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")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Eleven
+:PROPERTIES:
+:header-args: :tangle \"foo.txt\"
+:END:
+#+begin_src conf :tangle yes
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 12. tangle-file-with-spaces
+ (equal '(:tangle "file with spaces.txt")
+ (org-test-with-temp-text
+ "\
+* Twelve
+:PROPERTIES:
+:header-args: :tangle \"foo.txt\"
+:END:
+** A
+#+begin_src conf :tangle \"file with spaces.txt\"
+#+end_src"
+ (test-ob/get-src-block-property :tangle)))))
+
(ert-deftest test-ob/inline-src-blocks ()
(should
(= 1
--
2.41.0
From 1a2aae5d89aeb665f5e6a4420f6f6a1a00e5056f Mon Sep 17 00:00:00 2001
From: Mehmet Tekman <mtekma...@gmail.com>
Date: Fri, 4 Aug 2023 13:07:14 +0200
Subject: [PATCH 4/4] (org-babel-common-header-args-w-values): Added mutually
exclusive tangle groups relating to desired tangle sync actions
---
lisp/ob-core.el | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/lisp/ob-core.el b/lisp/ob-core.el
index cd6c6708c..f901a75ee 100644
--- a/lisp/ob-core.el
+++ b/lisp/ob-core.el
@@ -441,7 +441,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))
--
2.41.0
From c8f8e1cf6dbf88162a11b520578b32b4ddd8441a Mon Sep 17 00:00:00 2001
From: Mehmet Tekman <mtekma...@gmail.com>
Date: Wed, 10 May 2023 17:38:22 +0200
Subject: [PATCH 2/4] * 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.
added ob-core
ihors suggestions implemented
---
lisp/ob-core.el | 154 +++++++++++++++++++++++++++++++++++++-----------
1 file changed, 121 insertions(+), 33 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)
--
2.41.0
From 90c2e30cd27e783670856ff618efc5c0d4674bdd Mon Sep 17 00:00:00 2001
From: Mehmet Tekman <mtekma...@gmail.com>
Date: Fri, 4 Aug 2023 13:06:58 +0200
Subject: [PATCH 3/4] * testing/lisp/test-ob.el: update tests according to new
merge strategy, with emphasis on `:tangle' headers for syncing actions.
updated test
---
testing/lisp/test-ob.el | 43 ++++++++++++++++++++++++++++++++---------
1 file changed, 34 insertions(+), 9 deletions(-)
diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el
index f12533258..d51937b69 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
@@ -439,18 +438,44 @@ PROPERTIES is a list of property keywords or a single keyword."
#+begin_src conf :tangle yes
#+end_src"
(test-ob/get-src-block-property :tangle))))
- (should ;; 12. tangle-file-with-spaces
+ (should ;; 12. simple-file-with-spaces
+ (equal '(:tangle "file with spaces.txt import")
+ (org-test-with-temp-text "\
+#+PROPERTY: header-args :tangle \"file with spaces.txt\" sync
+* Twelve
+#+begin_src conf :tangle import
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 13. hierarchical-tangle-file-with-spaces
(equal '(:tangle "file with spaces.txt")
(org-test-with-temp-text
"\
-* Twelve
+* Thirteen
:PROPERTIES:
:header-args: :tangle \"foo.txt\"
:END:
** A
#+begin_src conf :tangle \"file with spaces.txt\"
#+end_src"
- (test-ob/get-src-block-property :tangle)))))
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 14. do-not-tangle
+ (equal '(:tangle "no")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle /tmp/default_tangle.txt
+* Fourteen
+#+begin_src emacs-lisp :tangle no
+#+end_src"
+ (test-ob/get-src-block-property :tangle))))
+ (should ;; 15. headers-dont-cancel-out
+ (equal '(:tangle "relative.el")
+ (org-test-with-temp-text
+ "\
+#+PROPERTY: header-args :tangle relative.el
+* Fifteen
+#+begin_src emacs-lisp :tangle relative.el
+#+end_src"
+ (test-ob/get-src-block-property :tangle)))))
(ert-deftest test-ob/inline-src-blocks ()
(should
--
2.41.0
