wilderjds
/
.emacs.d
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix tangle to multiple files

Browse Source
master
Jacopo De Simoi 5 years ago
parent aafa71304e
commit b6d0b5186a
1 changed files with 63 additions and 59 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 122
      global.org

122
global.org
Unescape View File

@ -1007,66 +1007,70 @@
This is some some super-clever stuff. See This is some some super-clever stuff. See
[https://emacs.stackexchange.com/questions/39032/tangle-the-same-src-block-to-different-files] [https://emacs.stackexchange.com/questions/39032/tangle-the-same-src-block-to-different-files]
#+begin_src emacs-lisp #+begin_src emacs-lisp
(defun org-babel-tangle-collect-blocks-handle-tangle-list (&optional language tangle-file) (defun org-babel-tangle-collect-blocks-handle-tangle-list (&optional language tangle-file)
"Can be used as :override advice for `org-babel-tangle-collect-blocks'. "Can be used as :override advice for `org-babel-tangle-collect-blocks'.
Handles lists of :tangle files." Handles lists of :tangle files."
(let ((counter 0) last-heading-pos blocks) (let ((counter 0) last-heading-pos blocks)
(org-babel-map-src-blocks (buffer-file-name) (org-babel-map-src-blocks (buffer-file-name)
(let ((current-heading-pos (let ((current-heading-pos
(org-with-wide-buffer (org-with-wide-buffer
(org-with-limited-levels (outline-previous-heading))))) (org-with-limited-levels (outline-previous-heading)))))
(if (eq last-heading-pos current-heading-pos) (cl-incf counter) (if (eq last-heading-pos current-heading-pos) (cl-incf counter)
(setq counter 1) (setq counter 1)
(setq last-heading-pos current-heading-pos))) (setq last-heading-pos current-heading-pos)))
(unless (org-in-commented-heading-p) (unless (org-in-commented-heading-p)
(let* ((info (org-babel-get-src-block-info 'light))
(src-lang (nth 0 info))
(src-tfiles (cdr (assq :tangle (nth 2 info))))) ; Tobias: accept list for :tangle
(unless (consp src-tfiles) ; Tobias: unify handling of strings and lists for :tangle
(setq src-tfiles (list src-tfiles))) ; Tobias: unify handling
(dolist (src-tfile src-tfiles) ; Tobias: iterate over list
(unless (or (string= src-tfile "no")
(and tangle-file (not (equal tangle-file src-tfile)))
(and language (not (string= language src-lang))))
;; Add the spec for this block to blocks under its
;; language.
(let ((by-lang (assoc src-lang blocks))
(block (org-babel-tangle-single-block counter)))
(setcdr (assoc :tangle (nth 4 block)) src-tfile) ; Tobias:
(if by-lang (setcdr by-lang (cons block (cdr by-lang)))
(push (cons src-lang (list block)) blocks)))))))) ; Tobias: just ()
;; Ensure blocks are in the correct order.
(mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) blocks)))
(defun org-babel-tangle-single-block-handle-tangle-list (oldfun block-counter &optional only-this-block)
"Can be used as :around advice for `org-babel-tangle-single-block'.
If the :tangle header arg is a list of files. Handle all files"
(let* ((info (org-babel-get-src-block-info)) (let* ((info (org-babel-get-src-block-info))
(params (nth 2 info)) (src-lang (nth 0 info))
(tfiles (cdr (assoc :tangle params)))) (src-tfiles (cdr (assq :tangle (nth 2 info))))) ; Tobias: accept list for :tangle
(if (null (and only-this-block (consp tfiles))) (unless (consp src-tfiles) ; Tobias: unify handling of strings and lists for :tangle
(funcall oldfun block-counter only-this-block) (setq src-tfiles (list src-tfiles))) ; Tobias: unify handling
(cl-assert (listp tfiles) nil (dolist (src-tfile src-tfiles) ; Tobias: iterate over list
":tangle only allows a tangle file name or a list of tangle file names") (unless (or (string= src-tfile "no")
(let ((ret (mapcar (and tangle-file (not (equal tangle-file src-tfile)))
(lambda (tfile) (and language (not (string= language src-lang))))
(let (old-get-info) ;; Add the spec for this block to blocks under its
(cl-letf* (((symbol-function 'old-get-info) (symbol-function 'org-babel-get-src-block-info)) ;; language.
((symbol-function 'org-babel-get-src-block-info) (let ((by-lang (assoc src-lang blocks))
`(lambda (&rest get-info-args) (block (org-babel-tangle-single-block counter)))
(let* ((info (apply 'old-get-info get-info-args)) (setcdr (assoc :tangle (nth 4 block)) src-tfile) ; Tobias:
(params (nth 2 info)) (if by-lang (setcdr by-lang (cons block (cdr by-lang)))
(tfile-cons (assoc :tangle params))) (push (cons src-lang (list block)) blocks)))))))) ; Tobias: just ()
(setcdr tfile-cons ,tfile) ;; Ensure blocks are in the correct order.
info)))) (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) blocks)))
(funcall oldfun block-counter only-this-block))))
tfiles))) (defun org-babel-tangle-single-block-handle-tangle-list (oldfun block-counter &optional only-this-block)
(if only-this-block "Can be used as :around advice for `org-babel-tangle-single-block'.
(list (cons (cl-caaar ret) (mapcar #'cadar ret))) If the :tangle header arg is a list of files. Handle all files"
ret))))) (let* ((info (org-babel-get-src-block-info))
(params (nth 2 info))
(advice-add 'org-babel-tangle-collect-blocks :override #'org-babel-tangle-collect-blocks-handle-tangle-list) (tfiles (cdr (assoc :tangle params))))
(advice-add 'org-babel-tangle-single-block :around #'org-babel-tangle-single-block-handle-tangle-list) (message nil)
(if (null (and only-this-block (consp tfiles)))
(funcall oldfun block-counter only-this-block)
(cl-assert (listp tfiles) nil
":tangle only allows a tangle file name or a list of tangle file names")
(let ((ret (mapcar
(lambda (tfile)
(message tfile)
(sleep-for 1)
(let (old-get-info)
(cl-letf* (((symbol-function 'old-get-info) (symbol-function 'org-babel-get-src-block-info))
((symbol-function 'org-babel-get-src-block-info)
`(lambda (&rest get-info-args)
(let* ((info (apply 'old-get-info get-info-args))
(params (nth 2 info))
(tfile-cons (assoc :tangle params)))
(setcdr tfile-cons ,tfile)
info))))
(funcall oldfun block-counter only-this-block))))
tfiles)))
(if only-this-block
(list (cons (cl-caaar ret) (mapcar #'cadar ret)))
ret)))))
(advice-add 'org-babel-tangle-collect-blocks :override #'org-babel-tangle-collect-blocks-handle-tangle-list)
(advice-add 'org-babel-tangle-single-block :around #'org-babel-tangle-single-block-handle-tangle-list)
#+end_src #+end_src
*** Append tangle *** Append tangle
#+begin_src emacs-lisp #+begin_src emacs-lisp

Write Preview
Loading…
Cancel
Save