emenel/doomemacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

feat(org): add "doom +org tangle" command

Browse source 
Introduces a formal bin/doom command for tangling files, to replace the
non-functional bin/org-capture binscript.

Close: #6599
Close: #6267
This commit is contained in:
Henrik Lissner 2024-09-01 17:38:33 -04:00
parent 0d405329fe
commit 295ab7ed3a
No known key found for this signature in database
GPG key ID: B60957CA074D39A3
2 changed files with 149 additions and 159 deletions
Download patch file Download diff file Expand all files Collapse all files

159
bin/org-tangle
View file

@ -1,159 +0,0 @@
#!/usr/bin/env sh
":"; exec emacs --quick --script "$0" -- "$@" # -*- mode: emacs-lisp; lexical-binding: t; -*-
;;; bin/org-tangle
;; Tangles source blocks from org files. Also expands #+INCLUDE directives,
;; unlike vanilla `ob-tangle'. Debug/info messages are directed to stderr and
;; can be ignored.
;;
;; -l/--lang LANG
;; Only include blocks in the specified language (e.g. emacs-lisp).
;; -a/--all
;; Tangle all blocks by default (unless it has :tangle nil set or a
;; :notangle: tag)
;; -t/--tag TAG
;; --and TAG
;; --or TAG
;; Only include blocks in trees that have these tags. Combine multiple --and
;; and --or's, or just use --tag (implicit --and).
;; -p/--print
;; Prints tangled code to stdout instead of to files
;;
;; Usage: org-tangle [[-l|--lang] LANG] some-file.org another.org
;; Examples:
;; org-tangle -l sh modules/some/module/README.org > install_module.sh
;; org-tangle -l sh modules/lang/go/README.org | sh
;; org-tangle --and tagA --and tagB my/literate/config.org
(require 'cl-lib)
(require 'ox)
(require 'ob-tangle)
(defun usage ()
(with-temp-buffer
(insert (format "%s %s [OPTIONS] [TARGETS...]\n"
"Usage:"
(file-name-nondirectory load-file-name))
"\n"
"A command line interface for tangling org-mode files. TARGETS can be\n"
"files or folders (which are searched for org files recursively).\n"
"\n"
"This is useful for literate configs that rely on command line\n"
"workflows to build it.\n"
"\n"
"Example:\n"
" org-tangle some-file.org\n"
" org-tangle literate/config/\n"
" org-tangle -p -l sh scripts.org > do_something.sh\n"
" org-tangle -p -l python -t tagA -t tagB file.org | python\n"
"\n"
"Options:\n"
" -a --all\t\tTangle all blocks by default\n"
" -l --lang LANG\tOnly tangle blocks written in LANG\n"
" -p --print\t\tPrint tangled output to stdout than to files\n"
" -t --tag TAG\n"
" --and TAG\n"
" --or TAG\n"
" Lets you tangle org blocks by tag. You may have more than one\n"
" of these options.\n")
(princ (buffer-string))))
(defun *org-babel-tangle (fn &rest args)
"Don't write tangled blocks to files, print them to stdout."
(cl-letf (((symbol-function 'write-region)
(lambda (start end filename &optional append visit lockname mustbenew)
(princ (buffer-string)))))
(apply fn args)))
(defun *org-babel-tangle-collect-blocks (&optional language tangle-file)
"Like `org-babel-tangle-collect-blocks', but will ignore blocks that are in
trees with the :notangle: tag."
(let ((counter 0) last-heading-pos blocks)
(org-babel-map-src-blocks (buffer-file-name)
(let ((current-heading-pos
(org-with-wide-buffer
(org-with-limited-levels (outline-previous-heading)))))
(if (eq last-heading-pos current-heading-pos) (cl-incf counter)
(setq counter 1)
(setq last-heading-pos current-heading-pos)))
(unless (org-in-commented-heading-p)
(require 'org)
(let* ((tags (org-get-tags-at))
(info (org-babel-get-src-block-info 'light))
(src-lang (nth 0 info))
(src-tfile (cdr (assq :tangle (nth 2 info)))))
(cond ((member "notangle" tags))
((and (or or-tags and-tags)
(or (not and-tags)
(let ((a (cl-intersection and-tags tags :test #'string=))
(b and-tags))
(not (or (cl-set-difference a b :test #'equal)
(cl-set-difference b a :test #'equal)))))
(or (not or-tags)
(cl-intersection or-tags tags :test #'string=))
t))
((or (not (or all-blocks src-tfile))
(string= src-tfile "no") ; tangle blocks by default
(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)))
(if by-lang
(setcdr by-lang (cons block (cdr by-lang)))
(push (cons src-lang (list block)) blocks))))))))
;; Ensure blocks are in the correct order.
(mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) blocks)))
(advice-add #'org-babel-tangle-collect-blocks
:override #'*org-babel-tangle-collect-blocks)
(defvar all-blocks nil)
(defvar and-tags nil)
(defvar or-tags nil)
(let (lang srcs and-tags or-tags)
(pop argv)
(while argv
(let ((arg (pop argv)))
(pcase arg
((or "-h" "--help")
(usage)
(error ""))
((or "-a" "--all")
(setq all-blocks t))
((or "-l" "--lang")
(setq lang (pop argv)))
((or "-p" "--print")
(advice-add #'org-babel-tangle :around #'*org-babel-tangle))
((or "-t" "--tag" "--and")
(push (pop argv) and-tags))
("--or"
(push (pop argv) or-tags))
((guard (string-match-p "^--lang=" arg))
(setq lang (cadr (split-string arg "=" t t))))
((guard (file-directory-p arg))
(setq srcs
(append (directory-files-recursively arg "\\.org$")
srcs)))
((guard (file-exists-p arg))
(push arg srcs))
(_ (error "Unknown option or file: %s" arg)))))
(dolist (file srcs)
(let ((backup (make-temp-file (file-name-base file) nil ".backup.org")))
(unwind-protect
;; Prevent slow hooks from interfering
(let (org-mode-hook org-confirm-babel-evaluate)
;; We do the ol' switcheroo because `org-babel-tangle' writes
;; changes to the current file, which would be imposing on the user.
(copy-file file backup t)
(with-current-buffer (find-file-noselect file)
;; Tangling doesn't expand #+INCLUDE directives, so we do it
;; ourselves, since includes are so useful for literate configs!
(org-export-expand-include-keyword)
(org-babel-tangle nil nil lang)))
(ignore-errors (copy-file backup file t))
(ignore-errors (delete-file backup)))))
(kill-emacs 0))

149
modules/lang/org/cli.el Normal file
View file

@ -0,0 +1,149 @@
;;; lang/org/cli.el -*- lexical-binding: t; -*-
(defcli! () ()
"Commands to invoke Org's powerful capabilities."
:partial t)
(defcli! (tangle)
((all? ("-a" "--all") "Tangle all src blocks, unconditionally")
(print? ("-p" "--print") "Print the tangled results to stdout (implies -q/--quiet)")
(quiet? ("-q" "--quiet") "Don't log any status messages to stdout")
(lang ("-l" "--lang" lang))
&multiple
(tags ("-t" "--tag" "--and" "--or" tag) "Target blocks under headers with specific tags")
&args paths)
"Tangle an org file in `PATHS'.
`PATHS' can be files or folders (which are searched for org files,
recursively).
EXAMPLES:
%p %c some-file.org
%p %c literate/config/
%p %c `-p' `-l' sh scripts.org > script.sh
%p %c `-p' `-l' python `-t' tagA `-t' tagB file.org | python"
(unless paths
(user-error "No paths to org files provided."))
;; Prefer module's version of org, if available.
;; TODO: Handle this upstream.
(add-to-list
'load-path
(cl-find-if #'file-exists-p
(list (doom-path straight-base-dir "straight" straight-build-dir "org")
(doom-path straight-base-dir "straight" "repos" "org"))))
(require 'org)
(require 'ox)
(require 'ob-tangle)
(letf! ((defun org-babel-tangle-collect-blocks (&optional language tangle-file)
"Ignore blocks that are in trees with the :notangle: tag."
(let ((counter 0) last-heading-pos blocks)
(org-babel-map-src-blocks (buffer-file-name)
(let ((current-heading-pos
(if (org-element--cache-active-p)
(or (org-element-property :begin (org-element-lineage (org-element-at-point) '(headline) t)) 1)
(org-with-wide-buffer
(org-with-limited-levels (outline-previous-heading))))))
(if (eq last-heading-pos current-heading-pos) (cl-incf counter)
(setq counter 1)
(setq last-heading-pos current-heading-pos)))
(unless (or (org-in-commented-heading-p)
(org-in-archived-heading-p))
(let* ((tags (org-get-tags-at))
(info (org-babel-get-src-block-info 'no-eval))
(src-lang (nth 0 info))
(src-tfile (cdr (assq :tangle (nth 2 info)))))
(cond ((member "notangle" tags))
((let* ((tags (seq-group-by (fn! (equal (car %) "--or")) tags))
(or-tags (mapcar #'cdr (cdr (assq t tags))))
(and-tags (mapcar #'cdr (cdr (assq nil tags))))
(all-tags (append or-tags and-tags)))
(and (or or-tags and-tags)
(or (not and-tags)
(let ((a (cl-intersection and-tags all-tags :test #'string=))
(b and-tags))
(not (or (cl-set-difference a b :test #'equal)
(cl-set-difference b a :test #'equal)))))
(or (not or-tags)
(cl-intersection or-tags all-tags :test #'string=))
t)))
((or (not src-tfile)
(string= src-tfile "no") ; tangle blocks by default
(if tangle-file (not (equal tangle-file src-tfile)))
(if language (not (string= language src-lang)))))
;; Add the spec for this block to blocks under its language.
((let* ((block (org-babel-tangle-single-block counter))
(src-tfile (cdr (assq :tangle (nth 4 block))))
(file-name (org-babel-effective-tangled-filename
(nth 1 block) src-lang src-tfile))
(by-fn (assoc file-name blocks)))
(if by-fn
(setcdr by-fn (cons (cons src-lang block) (cdr by-fn)))
(push (cons file-name (list (cons src-lang block)))
blocks))))))))
;; Ensure blocks are in the correct order.
(mapcar (lambda (b) (cons (car b) (nreverse (cdr b))))
(nreverse blocks))))
(success nil))
(if print? (setq quiet? t))
(when (and all? (not quiet?))
(print! (warn "Tangling all blocks, unconditionally...")))
(dolist (file (cl-loop for path in (mapcar #'expand-file-name paths)
if (file-directory-p path)
append (doom-files-in path :type 'files :match "\\.org\\'")
else if (file-exists-p path)
collect path
else do (print! (error "Can't find %s. Skipping..." (path path))))
(or success (exit! 1)))
(unless quiet?
(print! (start "Reading %s...") (path file)))
(let ((backup (make-temp-file (file-name-base file) nil ".backup.org"))
;; Prevent slow initialization from interfering
(org-startup-indented nil)
(org-startup-folded nil)
(vc-handled-backends nil)
;; Prevent unwanted entries in recentf, or formatters, or
;; anything that could be on these hooks, really. Nothing else
;; should be touching these files (particularly in interactive
;; sessions).
(write-file-functions nil)
(before-save-hook nil)
(after-save-hook nil)
;; Prevent infinite recursion due to recompile-on-save hooks
;; later, and speed up `org-mode' init.
(org-mode-hook nil)
(org-inhibit-startup t)
;; Allow evaluation of src blocks at tangle-time (would abort
;; them otherwise). This is a security hazard, but Doom will
;; trust that you know what you're doing!
(org-confirm-babel-evaluate nil)
;; Tangle everything by default.
(org-babel-default-header-args (copy-sequence org-babel-default-header-args)))
(when all?
(setf (alist-get :tangle org-babel-default-header-args) "yes"))
(unwind-protect
(progn
;; Do the ol' switcheroo because `org-babel-tangle' writes changes
;; to the current file, which would be imposing on the user.
(copy-file file backup t)
(with-current-buffer (delay-mode-hooks (find-file-noselect file))
;; Tangling doesn't expand #+INCLUDE directives, so we do it
;; ourselves, since includes are so useful for literate configs!
(org-export-expand-include-keyword)
(if-let ((results (reverse (org-babel-tangle nil nil lang))))
(dolist (file results)
(if (not quiet?)
(print-group!
(setq success t)
(print! (success "Tangled to %s") (path file)))
(when print?
(print! "%s" (doom-file-read file))
(delete-file file))))
(unless quiet?
(print-group!
(print! (warn "Nothing to tangle from %s") (path file)))))))
(ignore-errors (copy-file backup file t))
(ignore-errors (delete-file backup)))))))