Code walkerを使ってみる
Lisp Advent Calendar 五日目の記事です。
Lispではコードはデータであり、主にリスト構造からなります。
そのため、プログラムからコードを扱うにはリストを操作する関数を書けば良いはずです。
ただ、リストをそのままコードとして扱おうとすると、うまくいかない例があります。
例えば関数listの呼び出しを列挙したいとします。
(list args...)
引数で受け取った式の中からlistの関数呼び出しを列挙する関数を書いてみます。
(defun collect-list-form (x)
(let ((acc '()))
(labels ((recursive (x)
(when (consp x)
(when (eq (first x) 'list)
(push x acc))
(mapc #'recursive x))))
(recursive x)
acc)))
以下の例はうまく動いているように見えます。
(collect-list-form '(progn
(list a)
(list (list 1 2)
(list a b c)
(list))))
=> ((LIST)
(LIST A B C)
(LIST 1 2)
(LIST (LIST 1 2) (LIST A B C) (LIST))
(LIST A))
ただ次の式はうまくいきません。
(collect-list-form '(let ((list x)) list))
=> ((LIST X))
上記の式の中にlistの関数呼び出しは無いはずですが、返り値に(list x)が含まれています。
これはcollect-list-form関数が、letの第一引数は変数束縛を表すということを知らないからです。
この問題を解決するためには、Common Lispの全てのスペシャルフォーム用の処理をcollect-list-form関数の中で扱う必要があります。
https://www.lispworks.com/documentation/HyperSpec/Body/03_ababa.htm を見てみると、スペシャルフォームの数は25個あるようです。
コードを扱う関数を書く度にこれらのスペシャルフォームの処理を書くのは大変ですし、共通化できるはずです。
そこで、Code walkerを使うとこの問題を解決できます。
既存のCode walker
sb-walker
最もよく使われているsbclでは、sb-walkerというモジュールでCode walkerを提供しています。
これを使うと上記の問題の例は期待通りの結果を返します。
(let ((acc '()))
(sb-walker:walk-form '(let ((list x)) (list 1 2 3))
nil
(lambda (subform context env)
(declare (ignore context env))
(when (and (consp subform)
(eq 'list (first subform)))
(push subform acc))
subform))
acc)
=> ((LIST 1 2 3))
arnesi
古いものですが、https://bese.common-lisp.dev/arnesi.html という汎用ライブラリがあり、その中にCode walkerが含まれています。
上記のsb-walkerよりも機能面で優れており柔軟ですが、現状のsbclでは動かない部分があるのでフォークして修正したものを使っています。
応用例
関数が出しうるエラーを一覧する
例えばWebアプリケーションを作っていて、そのアプリケーションはREST APIを提供しているとします。
各APIは様々なエラーレスポンスを返しますが、そのエラーレスポンスの情報を含んだドキュメントを手で保守するのはとても大変です。
また、error関数を呼び出して、エラーレスポンス用のconditionを作り、それをより上位の関数呼び出しがハンドリングし、最終的にHTTPレスポンスとして返されます。
ということはAPIのエンドポイントに対応した関数から呼び出される関数を辿り、最終的にerror関数呼び出しが見つかります。
そのerror関数の引数にどのコンディションが渡されているかを列挙すれば、特定のAPIのエラーレスポンスの一覧を自動生成できるのではないでしょうか。
これはcode walkerを使うことで実現できます。
実際に上記の事を行う簡単なコードを用意してみました。
(in-package :cl-user)
(define-condition example-error (error) ())
(define-condition foo-error (example-error) ())
(define-condition bar-error (example-error) ())
(defun foo (value)
(unless value
(error 'foo-error))
t)
(defun bar (value)
(unless value
(error 'bar-error))
(foo value))
(defun entrypoint (value)
(foo value)
(bar value))
(ql:quickload '(:alexandria :arnesi :trivia))
(defvar *current-defun-name* nil)
(defvar *seen-functions* '())
(defvar *callee-table* (make-hash-table :test 'equal))
(defvar *caller-table* (make-hash-table :test 'equal))
(defvar *call-error-table* (make-hash-table :test 'equal))
(defun callee (fn-name)
(gethash fn-name *callee-table*))
(defun (setf callee) (callee fn-name)
(setf (gethash fn-name *callee-table*) callee))
(defun caller (fn-name)
(gethash fn-name *caller-table*))
(defun (setf caller) (caller fn-name)
(setf (gethash fn-name *caller-table*) caller))
(defun called-errors (fn-name)
(gethash fn-name *call-error-table*))
(defun (setf called-errors) (errors fn-name)
(setf (gethash fn-name *call-error-table*) errors))
(defun clear-info ()
(dolist (fn-name *seen-functions*)
(setf (callee fn-name) '())
(setf (caller fn-name) '())
(setf (called-errors fn-name) '()))
(setf *seen-functions* '()))
(defun save-call (from-fn-name to-fn-name)
(check-type from-fn-name symbol)
(check-type to-fn-name symbol)
(pushnew from-fn-name *seen-functions*)
(pushnew to-fn-name *seen-functions*)
(pushnew from-fn-name (caller to-fn-name))
(pushnew to-fn-name (callee from-fn-name))
(values))
(defun save-call-errors (fn-name error-form)
(push error-form (called-errors fn-name)))
(arnesi::def-function-walker-handler sb-int:named-lambda (form parent env)
(destructuring-bind (name args &rest body)
(rest form)
(declare (ignore args body))
(when (symbolp name)
(let ((*current-defun-name* name))
(arnesi::walk-named-lambda form parent env)))))
(defmethod arnesi::walk-form-aux :around ((dispatcher (eql 'arnesi::application)) form parent env)
(when *current-defun-name*
(save-call *current-defun-name* (first form))
(trivia:match form
((list 'cl:error (list 'quote error-name))
(save-call-errors *current-defun-name* error-name))))
(call-next-method))
(defun walk-all ()
(dolist (form (uiop:read-file-forms "example.lisp"))
(arnesi:walk-form form)))
(defun collect-errors-thrown-by-function (name)
(let ((error-forms-so-far '())
(visited (make-hash-table)))
(labels ((collect-errors (name)
(setf error-forms-so-far (append error-forms-so-far (called-errors name))))
(recursive (name)
(unless (gethash name visited)
(setf (gethash name visited) t)
(collect-errors name)
(mapc #'recursive (callee name)))))
(recursive name))
error-forms-so-far))
(defun list-errors (name)
(clear-info)
(walk-all)
(collect-errors-thrown-by-function name))
list-errors関数でexample.lispのentrypointが出しうるエラーのリストを返します。
(list-errors 'entrypoint)
=> (BAR-ERROR FOO-ERROR)
実際に使う場合はfuncallやapplyによる関数の呼び出し、utopianを使っている場合はutopian:throw-code、その他いくつかのマクロの考慮が必要になります。
また対象のアプリケーションコードを静的に解析できるように書く必要もあります。
他にも
- あるファイルの中の関数や構造体、クラスの定義の列挙
- コードの複雑度の計測
などに使えそうです
おわりに
ここではCode walkerとは何か、またその実用方法について上げていきました。
その後、既存のコードウォーカーでは物足りず自分で作ることになるのですが、それはまた別の機会に話せたらと思います。
Discussion