Improve bin/org-tangle #691

Adds tag filtering. Also tangles regularly by default (with -p/--print,
it will print tangled blocks to stdout instead).

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
+;; Tangles source blocks from org files. Debug/info messages are directed to
-;; messages are directed to stderr and can be ignored. -l/--lang can be used to
+;; stderr and can be ignored.
-;; only tangle blocks of a certain language.
+;;
+;;   -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 'cl-lib)
-
-(require 'org-install)
-(require 'org)
 (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))