From 295ab7ed3a20ba4619a142be15f5f2ef08d2adcf Mon Sep 17 00:00:00 2001 From: Henrik Lissner Date: Sun, 1 Sep 2024 17:38:33 -0400 Subject: [PATCH] feat(org): add "doom +org tangle" command Introduces a formal bin/doom command for tangling files, to replace the non-functional bin/org-capture binscript. Close: #6599 Close: #6267 --- bin/org-tangle | 159 ---------------------------------------- modules/lang/org/cli.el | 149 +++++++++++++++++++++++++++++++++++++ 2 files changed, 149 insertions(+), 159 deletions(-) delete mode 100755 bin/org-tangle create mode 100644 modules/lang/org/cli.el diff --git a/bin/org-tangle b/bin/org-tangle deleted file mode 100755 index b662ecbd5..000000000 --- a/bin/org-tangle +++ /dev/null @@ -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)) diff --git a/modules/lang/org/cli.el b/modules/lang/org/cli.el new file mode 100644 index 000000000..8429eeab6 --- /dev/null +++ b/modules/lang/org/cli.el @@ -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)))))))