Re: [ANN] lisp/ob-tangle-sync.el

[Mehmet Tekman <mtekman89@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 3218 bytes --]

Hello again,

I've attached two patches:

1. Tests for the existing merge parameters function, based on your
   last edits to my previous patch.

2. A rewrite of the entire merge parameters function, with the new
   tangle sync actions.

   It's a big patch mostly, because there were no intermediate commits
   in which the org framework wouldn't be broken. Hope that's okay!

** Brief Explanation of (2)

This attempts to address the problem of having an :any keyword in a
mutually exclusive group such as:

#+begin_src elisp
   '((tangle yes no :any)
     (import export skip sync))
#+end_src

Since every parameter (e.g. "export") is tested against both of these
groups, and since a parameter that matches `:any' could be anything,
then a parameter like "export" will match in both groups.

To get around this, a merge strategy (see: `org-babel--merge-headers')
builds an alist of exclusion groups that a parameter could belong to.

e.g for a header with `:tangle myfile.txt skip' would give an alist of

#+begin_src elisp
  (setq params-alist '(("skip" "tangle" "import")
                       ("myfile.txt" "tangle")))
#+end_src

Note that the exclusion groups are referenced by the first element in
the group, acting as an alist key of sorts. This assumes that each
exclusion group has a unique car.

Parameters with two or more cdr elements are stripped of the exclusion
group that have the `:any' parameter (i.e. "tangle"), resulting in:

#+begin_src elisp
  (setq params-alist '(("skip" "import")
                       ("myfile.txt" "tangle")))
#+end_src

This alist is then inverted so that the group exclusion car becomes
the key, and rearranged so that it follows the order of exclusion
group definition (in this case, "tangle" group first then then
"import" group).

#+begin_src elisp
  (setq group-alist '(("tangle" "myfile.txt")
                      ("import" "skip")))
#+end_src

As the merge parameters function is called repeatedly for the same
header, this builds to hold the whole related hierarchy of the org:

#+begin_src org
  ,#+PROPERTIES: header-args :tangle topfile.txt import

  ,* One
  :PROPERTIES:
  :header-args: :tangle skip
  :END:

  ,#+begin_src bash :tangle myfile.txt

  ,#+end_src
#+end_src

 which would yield:

#+begin_src elisp
  (setq group-alist '(("tangle" "myfile.txt" "no" "topfile.txt")
                      ("import" "skip" "import")))
#+end_src

Assuming the hierarchy is given in the reverse order of this alist,
the correct action is then taken as the car of these groups:

   `:tangle myfile.txt skip'


** Problems

It seems to work well for most tests, except for the "file with
spaces.txt" which I'm not sure how to proceed with. I feel like
patching at the level `org-babel--merge-params' is the wrong way to
go, and that I should patch it further upstream.

That upstream leads to `org-babel-read' which currently chomps the
quotes off anything it gets:

#+begin_src elisp
  (org-babel-read " \"my file with quotes\" ")
#+end_src

I don't know if this is the expected behaviour for quoted strings with
spaces, so before I proceed trying to patch this I thought I would
check in with you and ask whether I should start patching here or not.


Best,
Mehmet

[-- Attachment #2: 0001-testing-lisp-test-ob.el-New-tests-for-merge-params.patch --]
[-- Type: text/x-patch, Size: 5951 bytes --]

From dc2bb34b62b3725015ee9457c74397a9b0f11109 Mon Sep 17 00:00:00 2001
From: MT <mtekman89@gmail.com>
Date: Tue, 1 Aug 2023 05:14:46 +0200
Subject: [PATCH 1/2] * 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


[-- Attachment #3: 0002-lisp-ob-core.el-Rewrite-of-merge-babel-headers.patch --]
[-- Type: text/x-patch, Size: 11910 bytes --]

From 203153bfb3e49c82995f721518596a2b00127467 Mon Sep 17 00:00:00 2001
From: MT <mtekman89@gmail.com>
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