Org文学编程扩展
核心及一些特性的实现。
链接展开
结合 Org-Babel 提供额外的引用文本块的语义：
<<@(org-link)>>
配合 ‘org-open-at-point-global’ 使用，方便打开代
码块中的 Org 链接。
"Org Noweb Extension
<<@([[id:D:org-noweb-expand-link]])>>"
(cond*
((bind* (s? (stringp link)) p))
((bind* (m (and s? (locate link))) body)
(log "expanding %s" link)
(setq conf (plist-put conf :link link)
conf (plist-put conf :ref-props
ref-properties))
(org-with-point-at m
<<@([[id:P:pre:run-hook]])>>
;; 如果展开失败，设置 :failed 及
;; :err-msg, 并将 body 置为空串。
(setq body (expand conf))))
((bind* (_ (and s? (null m))))
(plist-put conf :failed t)
(plist-put conf :err-msg
(format "failed to expand %s"
link))
(setq body ""))
(body
(dolist (p (post-process))
(setq body (funcall p body conf)))
;; display warning
(when (plist-get conf :failed)
(display-warning
'org-noweb
(plist-get conf :err-msg)
:warning))
body)
<<@([[id:B:org-noweb-expand-link:cmd-set]])>>)
Locate
(lambda (link &optional signal-errors)
(let ((inhibit-message t)
(message-log-max nil)
(org-link-search-must-match-exact-headline t)
(org-link-frame-setup
`((file . find-file-other-window)
,@org-link-frame-setup))
(marker (make-marker)))
(condition-case msg
(save-window-excursion
;; 这个 guard 实际只对当前 buffer 有效，
;; 无法处理 open-link 跑到别的 buffer 的
;; 情况。但考虑到有时我们会 open 当前
;; buffer 中的 link, 为了防止因为可见性引
;; 发的链接查找失败，我们还是在这里加上这
;; 个 gaurd, 当然，也许还有更好的实现方法，
;; 但到时再说。
(org-with-wide-buffer
(if (not (stringp link))
(org-link-open link t)
(org-link-open-from-string link t))
(set-marker marker (point))))
(error
(when signal-errors
(signal (car msg) (cdr msg)))))))
Expand
;; conf 输入输出
;; 输入: :expanders.
;; 输出: :failed, :err-msg.
"展开位于 current point 的 Org element."
(!let ((link (plist-get conf :link))
ele type expand)
(cond
;; 展开文件
((with-temp-buffer
(org-mode)
(save-excursion (insert link))
(setq link (org-element-link-parser))
(and
(equal (org-element-property :type link)
"file")
(null (org-element-property
:search-option link))))
(substring-no-properties (buffer-string)))
;; 展开 Org 元素
((ignore
(setq ele (org-element-at-point)
type (org-element-type ele)
expand (expander type))))
((and expand (expand ele conf)))
;; 未定义
(t
(plist-put conf :failed t)
(plist-put
conf :err-msg
(format "%s unsupported target %S %S"
link (current-buffer) (point)))
"")))
日志
log
(lambda (log-target)
(lambda (fmt &rest args)
(when debug-on-error
(let* ((ts (format-time-string
"[%Y-%m-%d %H:%M:%S.%3N]"))
(buf (get-buffer-create
log-target)))
(with-current-buffer buf
(goto-char (point-max)))
(princ
(concat
(mapconcat
(lambda (line) (concat ts line))
(string-split
(apply #'format fmt args) "\n")
"\n")
"\n")
buf)))))
logging
(!def log
<<@([[id:log]])>>)
(!def log (log " log:org-noweb"))
logging default
(!def log 'message)
Org Babel接口
(with-temp-buffer
(org-mode)
(message "register org babel function: @")
(let* ((vars `((level (ignore))))
(ha (mapconcat
(lambda (v)
(format
":var %s=%s" (car v) (cadr v)))
vars " "))
(a (mapconcat
(lambda (v)
(format
":%s %s" (car v) (car v)))
vars " ")))
(insert
"#+name: @\n"
"#+begin_src emacs-lisp "
":var link=\"\" " ha "\n"
"(org-noweb-expand-link "
"(format \"%s\" link) " a ")\n"
"#+end_src")
(org-babel-lob-ingest)))
代码块展开
;; conf 输入输出
;; 输入: :link, :ref-props.
;; 输出: :lang, :failed, :err-msg.
(cond*
((bind* (link (plist-get conf :link))
(ref-props (plist-get conf :ref-props))
(info (org-babel-get-src-block-info))
(params (nth 2 info))))
;; 如果代码块参数 `:expand' 存在且其 sexp 求值
;; 为 nil 或 "no",
((and
(assq :expand params)
(member (alist-get :expand params)
'(nil "no")))
;; 表明该代码块在当前环境下拒绝展开。
(plist-put conf :failed t)
(plist-put conf :err-msg
(format "ignore %s." link))
"")
(t
(dolist (p ref-props)
(plist-put conf p (alist-get p params)))
(plist-put conf :lang (nth 0 info))
(org-babel-expand-noweb-references info)))
动态块展开
;; conf 输入输出
;; 输入: :link.
;; 输出: :block-name, :failed, :err-msg.
(cond*
((bind* (link (plist-get conf :link))
(ref-props (plist-get conf :ref-props))
(beg (org-element-contents-begin ele))
(end (org-element-contents-end ele))
;; org-element parser 与 org.el 中
;; 的不一致，导致解析失败，所以有了这段
;; workground 代码。
(org-element-dynamic-block-open-re
org-dblock-start-re)
(ele
(save-excursion
(save-match-data
(re-search-forward
org-dblock-start-re nil t)
(forward-line 0)
(org-element-dynamic-block-parser
nil nil))))
(args (org-element-property
:arguments ele))
(args (format "'(%s)" args))
(args (eval (read args)))
(block-name
(org-element-property
:block-name ele))))
;; 如果块参数 `:expand' 存在，且其 sexp 求值
;; 为 nil 或 "no",
((and
(plist-member args :expand)
(member (eval (plist-get args :expand))
'(nil "no")))
;; 表明该块在当前环境下拒绝展开。
(plist-put conf :failed t)
(plist-put conf :err-msg
(format "ignore %s." link))
"")
((ignore
(dolist (p ref-props)
(plist-put conf p
(eval (plist-get args p))))
(plist-put conf :block-name block-name)
(setq ele (buffer-substring beg end)
ele (string-trim ele))))
((and
(plist-member args :noweb)
(member (eval (plist-get args :noweb))
'(t "yes")))
;; 不在 temp buffer 里执行，保持执行上下文。
(replace-regexp-in-string
"^\0\\(#[+]\\(begin\\|end\\)_src\\)" "\\1"
(org-babel-expand-noweb-references
(with-temp-buffer
(org-mode)
(save-excursion
(insert
"#+begin_src C :noweb yes\n"
(replace-regexp-in-string
"\\(^#[+]\\(begin\\|end\\)_src\\)"
"\0\\1" ele)
"\n#+end_src"))
(org-babel-get-src-block-info)))))
(t (substring-no-properties ele)))
Elisp文档格式化
将文本格式化为 elisp docstring. 转义文本中的特殊字
符，并移除文本在根节点的缩进。
使用：
将文本置于 Org Dynamic Block elisp-docstring 中。
见 Info node ‘(org)Dynamic Blocks’.
-- 特殊字符转义
将“"”转义“\"”，“\”转义“\\”，此外，在 elisp
docstring 中，字符“`”，“'”，“"”需用“\=”转义。
见 Info node ‘(elisp)Text Quoting Style’.
:escape "no" 时不进行转义。
-- 缩进移除
如片段展开的最终结果嵌套在另外的片段中，且含缩进，
移除其缩进。
考虑如下代码块：
a:
(progn
<<b>>)
b:
(def remove-indent
"Remove indent.
<<c>>")
c:
移除文本在根节点的缩进。
正常情况下，展开 a 得：
(progn
(def remove-indent
"Remove indent
移除文本在根节点的缩进。"))
受 a 缩进影响，作为 b 的 docstring, c 每行都被填
充了缩进用的空白字符。移除缩进后，可得如下结果：
(progn
(def remove-indent
"Remove indent
移除文本在根节点的缩进。"))
"Format emacs lisp docstring.
<<@([[id:D:format-elisp-docstring]])>>"
;; 依赖: elisp-doc.
(let* ((name '("elisp-docstring"
"elisp" "elispdocstring"))
(mark "org-noweb-expand-link:")
(indent "^[ \t]*")
(mark (concat mark (car name))))
(cond
;; 无 body 时当 hook 用；
((null body)
(remove-hook 'org-babel-tangle-body-hook
elisp-doc)
(goto-char (point-min))
(while (re-search-forward
(concat indent mark) nil t)
(replace-match ""))
(goto-char (point-min))
(while (re-search-forward mark nil t)
(replace-match "")))
;; 有 body 时转义特殊字符，并往所有行行首加 mark.
((and
(member (plist-get conf :block-name) name)
(not (plist-get conf :failed)))
(add-hook 'org-babel-tangle-body-hook
elisp-doc)
;; (setf body (help--docstring-quote body))
(cond
((equal (plist-get conf :escape) "no")
(setf body (string-replace
"\"" "\\\"" body)))
(t
(with-temp-buffer
(save-excursion (insert body))
(while (re-search-forward "[`'\"\\]"
nil t)
(pcase (match-string 0)
("`" (replace-match "\\\\=`" nil t))
("'" (replace-match "\\\\='" nil t))
("\"" (replace-match "\\\"" nil t))
((and "\\" (guard (looking-at-p "=")))
(replace-match "\\\\=\\\\" nil t))
("\\" (replace-match "\\\\" nil t))))
(setq body (buffer-string)))))
(string-join
(mapcar
(lambda (line) (concat mark line))
(string-split body "\n"))
"\n"))
(t body)))
条件Tangle
条件展开。
通过 :expand Header Argument 指定代码块是否在其
被引用处展开. :expand 为 nil 或 "no" 时不展开
该代码块.
考虑不同平台的键绑定配置：
#+name: android
#+header: :expand (eq system-type 'android)
#+begin_src emacs-lisp :eval no
(defkey [c i] #'open-init.el)
#+end_src
#+name: window
#+header: :expand (eq system-type 'windows-nt)
#+begin_src emacs-lisp :eval no
(defkey [C-c i] #'open-init.el)
#+end_src
#+begin_src emacs-lisp :eval no
(keymap-setting platform
<<@([[id:ID::window]])>>
<<@([[id:ID::android]])>>)
#+end_src
Window 上的展开为：
#+begin_src emacs-lisp :eval no
(keymap-setting platform
(defkey [C-c i] #'open-init.el)
)
#+end_src
Android 上的展开为（自动删除展开为空的行）：
#+begin_src emacs-lisp :eval no
(keymap-setting platform
(defkey [c i] #'open-init.el))
#+end_src
"Conditional Tangle.
<<@([[id:D:conditional-tangle]])>>"
(cond
;; process body
(body
(cond
((and
(plist-get conf :failed)
(backtrace-frame 0 'org-babel-tangle))
(add-hook 'org-babel-tangle-body-hook
cond-tangle)
(let* ((msg (plist-get conf :err-msg))
(msg (or msg "_"))
(zw-spc (char-to-string ?\u200B)))
;; 用 org-noweb-expand-link 及零宽空格界
;; 定非法字符串。
(concat zw-spc
"org-noweb-expand-link " msg
zw-spc)))
(body)))
;; org-babel-tangle-body-hook
(t
(save-excursion
(let* ((zw-spc (char-to-string ?\u200B))
(re (concat
zw-spc
"org-noweb-expand-link .*"
zw-spc))
;; if remove trailing space
(re (concat re "[ \t]*"))
(re (format
"^\\(.*?\\)\\(%s\\)\\(\n?\\)"
re)))
(save-match-data
(goto-char (point-min))
(while (re-search-forward re nil t)
(if (and (length=
(save-match-data
(string-trim
(match-string 1)))
0)
(length= (match-string 3)
1))
(replace-match "")
(replace-match "" nil nil nil 2)))))
(remove-hook 'org-babel-tangle-body-hook
cond-tangle))))
2.n 版本
TARGET
;;; ! org noweb -*- lexical-binding: t; -*-
(!let (org-noweb-expand-link
(:apply (! apply macro) !def org
ref-props expanders expand-link
post-processes))
:collect-symbol: !def (!(indent 1)!)
(!def org (! org)) (!def log (![...]))
(org def 'noweb (! package nil :def '!def))
(!def !def
(!"s &optional v"
`(setf ,s (org noweb def ',s ,v))))
<<@([[id:F:logging]])>>
;;;; core
(!def ref-props (! package nil))
(ref-props def 'all
;; 这里复用 ref-props 的 symbol-value
(progn
(setf (symbol-value ref-props) nil)
()))
(ref-props def 'add
(![p] (push p (symbol-value ref-props))))
(!def expanders (! package nil))
(expanders def 'get
(![type] (eval `(,expanders ,type) t)))
<<@([[id:F:pre]])>>
(!def post-processes (! package nil))
(post-processes def 'all
(![] (cdr (! export all post-processes))))
(!def expand
(!let ((expander (expanders get)))
(![conf]
<<@([[id:expand]])>>)))
(!def locate
<<@([[id:locate]])>>)
;;;; expand-link
(!def expand-link
(! package
(!let ((post-process (post-processes all))
<<@([[id:E:pre]])>>
(ref-properties (symbol-value ref-props)))
(![link &rest conf]
<<@([[id:org-noweb-expand-link]])>>))))
(expand-link def 'locate locate)
)
;;;; register
(!def 'org-noweb-expand-link(! org noweb expand-link))
<<@([[id:P:register-@]])>>
;;;; features
<<@([[id:FEAT]])>>
;;;; documentation
<<@([[id:DOC]])>>
FEAT
<<@([[id:F:expand-src-block]])>>
<<@([[id:F:expand-dynamic-block]])>>
<<@([[id:F:format-elisp-docstring]])>>
<<@([[id:F:conditional-tangle]])>>
expand-src-block
(!let ((!def (! org noweb expanders def)))
(!def 'src-block
(![ele conf]
<<@([[id:expand-src-block]])>>)))
expand-dynamic-block
(!let ((!def (! org noweb expanders def)))
(!def 'dynamic-block
(![ele conf]
<<@([[id:expand-dynamic-block]])>>)))
conditional-tangle
(!let ((!def (! org noweb post-processes def)))
(!def 'cond-tangle
(!let ((cond-tangle (!def 'cond-tangle)))
(![&optional body conf]
<<@([[id:conditional-tangle]])>>))))
format-elisp-docstring
(!let ((!def (! org noweb post-processes def)))
(!def 'elisp-doc
(!let ((elisp-doc (!def 'elisp-doc))(org (! org))
(:apply org ! apply macro))
(defun org-dblock-write:elisp-docstring (p)
(insert (string-trim (plist-get p :content))))
(org noweb ref-props add :escape)
(![&optional body conf]
<<@([[id:format-elisp-docstring]])>>))))
