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

Improve bin/org-tangle #691

Browse source 
Adds tag filtering. Also tangles regularly by default (with -p/--print,
it will print tangled blocks to stdout instead).
This commit is contained in:
Henrik Lissner 2018-06-17 12:40:00 +02:00
parent 0fd8e1dd6b
commit 5400d608f4
No known key found for this signature in database
GPG key ID: 5F6C0EA160557395
1 changed files with 83 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

95
bin/org-tangle
View file

@ -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))