diff --git a/bin/org-tangle b/bin/org-tangle index fbe90fb23..c07d91ccf 100755 --- a/bin/org-tangle +++ b/bin/org-tangle @@ -2,19 +2,29 @@ ":"; exec emacs --quick --script "$0" -- "$@" # -*- mode: emacs-lisp; lexical-binding: t; -*- ;;; bin/org-tangle -;; Extracts source blocks from org files and prints them to stdout. Debug/info -;; messages are directed to stderr and can be ignored. -l/--lang can be used to -;; only tangle blocks of a certain language. +;; Tangles source blocks from org files. 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 modules/ui/doom/README.org > install_fira_mono.sh +;; 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 -(load (expand-file-name "../core/core.el" (file-name-directory load-file-name)) nil t) - -(require 'org-install) -(require 'org) +(require 'cl-lib) (require 'ob-tangle) (defun *org-babel-tangle (orig-fn &rest args) @@ -23,21 +33,82 @@ (lambda (start end filename &optional append visit lockname mustbenew) (princ (buffer-string))))) (apply orig-fn args))) -(advice-add #'org-babel-tangle :around #'*org-babel-tangle) -(let (lang srcs) +(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) +(defvar and-tags) +(defvar or-tags) +(let (lang srcs and-tags or-tags) (pop argv) (while argv (let ((arg (pop argv))) (pcase arg + ((or "-h" "--help") + ;; TODO + (error "No help yet, sorry!")) + ((or "-a" "--all") + (setq all-blocks t)) ((or "--lang" "-l") (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))))) + (_ (error "Unknown option or file: %s" arg))))) (dolist (file srcs) (org-babel-tangle-file file nil lang))