y2q_actionman’s ゴミクズチラ裏

内向きのメモ書きを置いてます

最近書いた define-setf-expander の例

この文章は、 Lisp SETF Advent Calendar 2018 - Qiita の 12/10分の記事として書かれました。

最近作った cl-json-pointer という適当なライブラリで、簡単な define-setf-expander を書いたのでご紹介です。

github.com


簡単に cl-json-pointer 紹介

RFC 6901 - JavaScript Object Notation (JSON) Pointer の実装です。

といっても JSON 自体を読んだりはせず、Common Lisp にある たくさんの JSON read/write ライブラリ のどれかと併用することとしています。 どのライブラリを使っても、 assoc-list か、 property-list か、 hash-table か、 standard-object のどれかで表現されるんだろ と見繕って、型を見て適当に引っ掛けています。

以下は、 cl-json での例です。

(use-package :cl-json-pointer)

(defparameter *json-str*
  "{ \"foo\": 0, \"bar\": 1}")

(defparameter *json-obj*
  (json:decode-json-from-string *json-str*))
;; => ((:FOO . 0) (:BAR . 1))

(get-by-json-pointer *json-obj* "/foo")
;; => 0

(get-by-json-pointer *json-obj* "/bar")
;; => 1


(get-by-json-pointer *json-obj* "/baz")
;; => NIL

(setf *json-object-flavor* :cl-json)     ; cl-json の alist 規約に合わせるための設定
(setf *json-obj* (set-by-json-pointer *json-obj* "/baz" 999))
;; => ((:BAZ . 999) (:FOO . 0) (:BAR . 1))

(get-by-json-pointer *json-obj* "/baz")
;; => 999

setf に対応させるには

目的

上では、値を取得する関数 (get-by-json-pointer) と、値を設定する関数 (set-by-json-pointer) は別々になっています。 しかし、やはり setf でまとめたいものです。以下のようになって欲しいですね:

(defparameter *json-str*
  "{}")

(defparameter *json-obj*
  (json:decode-json-from-string *json-str*))
;; => NIL

(get-by-json-pointer *json-obj* "/baz")
;; => NIL


(setf (get-by-json-pointer *json-obj* "/baz") 999)  ; こう書きたい!
;; => 999

*json-obj*
;; => ((:BAZ . 999))

(get-by-json-pointer *json-obj* "/baz")
;;=> 999

しかし、これは一筋縄ではいきません。これをやるためには、以下のフォームを見て・・

(setf (get-by-json-pointer *json-obj* "/baz") 999)

get-by-json-pointer 式の第一引数の箇所(この場合 *json-obj*)を書き換えなければいけません。 特に今回の場合は、 *json-obj*nil だったので、 新しい alist を割り当て、 *json-obj* 変数がそれを指すようにする 必要があります。

setf 関数は?

setf 関数では実現できません。以下のように書いても・・

(defun (setf get-by-json-pointer) (newval obj pointer &key (flavor *json-object-flavor*))
  (setf obj (set-by-json-pointer obj pointer newval :flavor flavor)) 
  newval)

残念ながら、 obj は関数内のローカルな変数なので、そこに代入しても意味がありません。

defsetf では?

defsetf でも実現できません。以下のように書けばいいのかなと思いますが・・

(defsetf get-by-json-pointer (obj pointer &key (flavor *json-object-flavor*)) (newval)
  `(progn (setf ,obj (set-by-json-pointer ,obj ,pointer ,newval :flavor ,flavor)) 
      ,newval))

obj には gensym された一時変数が bind されるので、 この obj を変更しても今回欲しい効果は得られません。 CLHS より

During the evaluation of the forms, the variables in the lambda-list and the store-variables are bound to names of temporary variables, generated as if by gensym or gentemp, that will be bound by the expansion of setf to the values of those subforms.

define-setf-expander を使う

この例の場合、元の setf フォームを受け取って、そこに *json-obj* と記述されているということを知らなければなりません。 このように、生の setf フォームに触れなければならない場合は、 define-setf-expander が必要になります。 今回は、以下のように定義することで所望の動作を実現できました。

(define-setf-expander get-by-json-pointer (obj pointer &key (flavor '*json-object-flavor*) &environment env)
  "A setf expansion for allowing `setf' to `(get-by-json-pointer ...)' forms."
  (multiple-value-bind (o-tmps o-vals o-newval o-setter o-getter)
      (get-setf-expansion obj env)
    (unless (length= o-newval 1)
      (error "setf to get-by-json-pointer requires the first arg is one value."))
    (with-gensyms (p-tmp flavor-tmp store)
      (values (list* p-tmp flavor-tmp o-tmps)
          (list* pointer flavor o-vals)
          (list store)
          `(let ((,(first o-newval) ; this binding influences `o-setter'.
              (set-by-json-pointer ,o-getter ,p-tmp ,store :flavor ,flavor-tmp)))
         ,o-setter
         ,store)
          `(get-by-json-pointer ,o-getter ,p-tmp :flavor ,flavor-tmp)))))

github 上のコードはこちらです。

まとめ

普段はほとんど使わない define-setf-expander ですが、ついに必要な場面に出会ってしまったので改めてめっちゃ調べてコードを書きました。そんな私の忘備録も兼ねてご紹介しました。

どの setf 定義を使うかですが:

  • 大抵の場合 :: setf 関数
  • マクロじゃないと困る時 :: defsetf
  • どうしても生の setf フォームに触れないといけないとき :: define-setf-expander

という感じかなと思います。