2013/05/06

hu.dwim.walker を使ってみる

Common Lisp といえばマクロ。マクロのいきつく先といえばコードウォーカー。ということで hu.dwim.walker というコードウォーカ一を使ってみた。

使い方としては次のような感じ。

  1. フォーム(S式)を hu.dwim.walker:walk-form で CLOS オブジェクトのAST(抽象構文木)にする。
  2. AST を hu.dwim.walker:substitute-ast-if や hu.dwim.walker:rewrite-ast を使って書き換える。
  3. hu.dwim.walker:unwalk-form で AST をフォーム(S式)に戻す。

cl-json を使うと次のように JSON をデコードできる。

(json:decode-json-from-string "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}")
;;⇒ ((:A . 1) (:B (:BB . 2)) (:C . 3))

これに対する assoc をちまち書きたくないので、シンボル1つで次のように展開されるマクロを書いてみる。

@a ⇒ (ASSOC "A" '((:A . 1) (:B (:BB . 2)) (:C . 3)) :TEST #'STRING-EQUAL)
@b.bb ⇒ (CDR (ASSOC "BB"
(CDR (ASSOC "B" '((:A . 1) (:B (:BB . 2)) (:C . 3)) :TEST #'STRING-EQUAL))
:TEST #'STRING-EQUAL))

これだけなら S式を単純に置換していくだけでも可能だけど

  • @で始まるシンボルでも let 等で束縛されていれば、上記の展開を行なわない。
  • マクロがネストされても問題ないようにする。

となるとコードウォーカーが必要になる。

ちゃんとしたドキュメントとかないようなので、テストやソースを見ながら書いたのがこれ。

(ql:quickload "hu.dwim.walker")
(ql:quickload "cl-json")
(ql:quickload "split-sequence")

(defun symbol-to-assoc-form (symbol decoded)
(let ((names (split-sequence:split-sequence #\. (subseq (symbol-name symbol) 1))))
(hu.dwim.walker:walk-form
(reduce (lambda (acc x)
`(cdr (assoc ,x ,acc :test #'string-equal)))
names
:initial-value decoded))))

(defun free-and-@-p (form)
(and (typep form 'hu.dwim.walker:free-variable-reference-form)
(char= #\@ (char (symbol-name (hu.dwim.walker:name-of form)) 0))))

(defun walk-with-json-body (decoded form env)
(let* ((walked (hu.dwim.walker:walk-form form
:environment (hu.dwim.walker:make-walk-environment env)))
(walked (hu.dwim.walker:rewrite-ast
walked
(lambda (parent field form)
(declare (ignore parent field))
(if (free-and-@-p form)
(symbol-to-assoc-form (hu.dwim.walker:name-of form) decoded)
form)))))
(hu.dwim.walker:unwalk-form walked)))

(defmacro with-json (json &body body &environment env)
(let ((decoded (gensym)))
`(let ((,decoded (json:decode-json-from-string ,json)))
,@(mapcar (lambda (form)
(walk-with-json-body decoded form env))
body))))

;; @a と @b.bb は json の値 1, 2 に @c は let の 999 になる。
;; with-json がネストしてても問題ない。
(with-json "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}"
(let ((@c 999))
(list @a @b.bb @c
(with-json "{\"a\": 10, \"b\": {\"bb\": 20}, \"c\": 30}"
(let ((@c 9990))
(list @a @b.bb @c))))))
;;⇒ (1 2 999 (10 20 9990))