#!/usr/bin/env bash
":"; exec emacs --quick --script "$0" -- "$@" # -*- mode: emacs-lisp; lexical-binding: t; -*-
;;; bin/org-tangle

;; 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 -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 'ob-tangle)

(defun *org-babel-tangle (orig-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 orig-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")
         ;; 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)))))

  (dolist (file srcs)
    (org-babel-tangle-file file nil lang))
  (kill-emacs 0))